Session Universal_Turing_Machine

Theory Turing

(* Title: thys/Turing.thy
   Author: Jian Xu, Xingyuan Zhang, and Christian Urban
   Modifications: Sebastiaan Joosten
*)

chapter ‹Turing Machines›

theory Turing
  imports Main
begin

section ‹Basic definitions of Turing machine›

datatype action = W0 | W1 | L | R | Nop

datatype cell = Bk | Oc

type_synonym tape = "cell list × cell list"

type_synonym state = nat

type_synonym instr = "action × state"

type_synonym tprog = "instr list × nat"

type_synonym tprog0 = "instr list"

type_synonym config = "state × tape"

fun nth_of where
  "nth_of xs i = (if i  length xs then None else Some (xs ! i))"

lemma nth_of_map [simp]:
  shows "nth_of (map f p) n = (case (nth_of p n) of None  None | Some x  Some (f x))"
  by simp

fun 
  fetch :: "instr list  state  cell  instr"
  where
    "fetch p 0 b = (Nop, 0)"
  | "fetch p (Suc s) Bk = 
     (case nth_of p (2 * s) of
        Some i  i
      | None  (Nop, 0))"
  |"fetch p (Suc s) Oc = 
     (case nth_of p ((2 * s) + 1) of
         Some i  i
       | None  (Nop, 0))"

lemma fetch_Nil [simp]:
  shows "fetch [] s b = (Nop, 0)"
  by (cases s,force) (cases b;force)

fun 
  update :: "action  tape  tape"
  where 
    "update W0 (l, r) = (l, Bk # (tl r))" 
  | "update W1 (l, r) = (l, Oc # (tl r))"
  | "update L (l, r) = (if l = [] then ([], Bk # r) else (tl l, (hd l) # r))" 
  | "update R (l, r) = (if r = [] then (Bk # l, []) else ((hd r) # l, tl r))" 
  | "update Nop (l, r) = (l, r)"

abbreviation 
  "read r == if (r = []) then Bk else hd r"

fun step :: "config  tprog  config"
  where 
    "step (s, l, r) (p, off) = 
     (let (a, s') = fetch p (s - off) (read r) in (s', update a (l, r)))"

abbreviation
  "step0 c p  step c (p, 0)"

fun steps :: "config  tprog  nat  config"
  where
    "steps c p 0 = c" |
    "steps c p (Suc n) = steps (step c p) p n"

abbreviation
  "steps0 c p n  steps c (p, 0) n"

lemma step_red [simp]: 
  shows "steps c p (Suc n) = step (steps c p n) p"
  by (induct n arbitrary: c) (auto)

lemma steps_add [simp]: 
  shows "steps c p (m + n) = steps (steps c p m) p n"
  by (induct m arbitrary: c) (auto)

lemma step_0 [simp]: 
  shows "step (0, (l, r)) p = (0, (l, r))"
  by (cases p, simp)

lemma steps_0 [simp]: 
  shows "steps (0, (l, r)) p n = (0, (l, r))"
  by (induct n) (simp_all)

fun
  is_final :: "config  bool"
  where
    "is_final (s, l, r) = (s = 0)"

lemma is_final_eq: 
  shows "is_final (s, tp) = (s = 0)"
  by (cases tp) (auto)

lemma is_finalI [intro]:
  shows "is_final (0, tp)"
  by (simp add: is_final_eq)

lemma after_is_final:
  assumes "is_final c"
  shows "is_final (steps c p n)"
  using assms 
  by(induct n;cases c;auto)

lemma is_final:
  assumes a: "is_final (steps c p n1)"
    and b: "n1  n2"
  shows "is_final (steps c p n2)"
proof - 
  obtain n3 where eq: "n2 = n1 + n3" using b by (metis le_iff_add)
  from a show "is_final (steps c p n2)" unfolding eq
    by (simp add: after_is_final)
qed

lemma not_is_final:
  assumes a: "¬ is_final (steps c p n1)"
    and b: "n2  n1"
  shows "¬ is_final (steps c p n2)"
proof (rule notI)
  obtain n3 where eq: "n1 = n2 + n3" using b by (metis le_iff_add)
  assume "is_final (steps c p n2)"
  then have "is_final (steps c p n1)" unfolding eq
    by (simp add: after_is_final)
  with a show "False" by simp
qed

(* if the machine is in the halting state, there must have 
   been a state just before the halting state *)
lemma before_final: 
  assumes "steps0 (1, tp) A n = (0, tp')"
  shows " n'. ¬ is_final (steps0 (1, tp) A n')  steps0 (1, tp) A (Suc n') = (0, tp')"
  using assms
proof(induct n arbitrary: tp')
  case (0 tp')
  have asm: "steps0 (1, tp) A 0 = (0, tp')" by fact
  then show "n'. ¬ is_final (steps0 (1, tp) A n')  steps0 (1, tp) A (Suc n') = (0, tp')"
    by simp
next
  case (Suc n tp')
  have ih: "tp'. steps0 (1, tp) A n = (0, tp') 
    n'. ¬ is_final (steps0 (1, tp) A n')  steps0 (1, tp) A (Suc n') = (0, tp')" by fact
  have asm: "steps0 (1, tp) A (Suc n) = (0, tp')" by fact
  obtain s l r where cases: "steps0 (1, tp) A n = (s, l, r)"
    by (auto intro: is_final.cases)
  then show "n'. ¬ is_final (steps0 (1, tp) A n')  steps0 (1, tp) A (Suc n') = (0, tp')"
  proof (cases "s = 0")
    case True (* in halting state *)
    then have "steps0 (1, tp) A n = (0, tp')"
      using asm cases by (simp del: steps.simps)
    then show ?thesis using ih by simp
  next
    case False (* not in halting state *)
    then have "¬ is_final (steps0 (1, tp) A n)  steps0 (1, tp) A (Suc n) = (0, tp')"
      using asm cases by simp
    then show ?thesis by auto
  qed
qed

lemma least_steps: 
  assumes "steps0 (1, tp) A n = (0, tp')"
  shows " n'. (n'' < n'. ¬ is_final (steps0 (1, tp) A n''))  
               (n''  n'. is_final (steps0 (1, tp) A n''))"
proof -
  from before_final[OF assms] 
  obtain n' where
    before: "¬ is_final (steps0 (1, tp) A n')" and
    final: "steps0 (1, tp) A (Suc n') = (0, tp')" by auto
  from before
  have "n'' < Suc n'. ¬ is_final (steps0 (1, tp) A n'')"
    using not_is_final by auto
  moreover
  from final 
  have "n''  Suc n'. is_final (steps0 (1, tp) A n'')" 
    using is_final[of _ _ "Suc n'"] by (auto simp add: is_final_eq)
  ultimately
  show " n'. (n'' < n'. ¬ is_final (steps0 (1, tp) A n''))  (n''  n'. is_final (steps0 (1, tp) A n''))"
    by blast
qed



(* well-formedness of Turing machine programs *)
abbreviation "is_even n  (n::nat) mod 2 = 0"

fun 
  tm_wf :: "tprog  bool"
  where
    "tm_wf (p, off) = (length p  2  is_even (length p)  
                    ((a, s)  set p. s  length p div 2 + off  s  off))"

abbreviation
  "tm_wf0 p  tm_wf (p, 0)"

abbreviation exponent :: "'a  nat  'a list" ("_  _" [100, 99] 100)
  where "x  n == replicate n x"

lemma hd_repeat_cases:
  "P (hd (a  m @ r))  (m = 0  P (hd r))  (nat. m = Suc nat  P a)"
  by (cases m,auto)

class tape =
  fixes tape_of :: "'a  cell list" ("<_>" 100)


instantiation nat::tape begin
definition tape_of_nat where "tape_of_nat (n::nat)  Oc  (Suc n)"
instance by standard
end

type_synonym nat_list = "nat list"

instantiation list::(tape) tape begin
fun tape_of_nat_list :: "('a::tape) list  cell list" 
  where 
    "tape_of_nat_list [] = []" |
    "tape_of_nat_list [n] = <n>" |
    "tape_of_nat_list (n#ns) = <n> @ Bk # (tape_of_nat_list ns)"
definition tape_of_list where "tape_of_list  tape_of_nat_list"
instance by standard
end

instantiation prod:: (tape, tape) tape begin
fun tape_of_nat_prod :: "('a::tape) × ('b::tape)  cell list" 
  where "tape_of_nat_prod (n, m) = <n> @ [Bk] @ <m>" 
definition tape_of_prod where "tape_of_prod  tape_of_nat_prod"
instance by standard
end

fun 
  shift :: "instr list  nat  instr list"
  where
    "shift p n = (map (λ (a, s). (a, (if s = 0 then 0 else s + n))) p)"

fun 
  adjust :: "instr list  nat  instr list"
  where
    "adjust p e = map (λ (a, s). (a, if s = 0 then e else s)) p"

abbreviation
  "adjust0 p  adjust p (Suc (length p div 2))"

lemma length_shift [simp]: 
  shows "length (shift p n) = length p"
  by simp

lemma length_adjust [simp]: 
  shows "length (adjust p n) = length p"
  by (induct p) (auto)


(* composition of two Turing machines *)
fun
  tm_comp :: "instr list  instr list  instr list" ("_ |+| _" [0, 0] 100)
  where
    "tm_comp p1 p2 = ((adjust0 p1) @ (shift p2 (length p1 div 2)))"

lemma tm_comp_length:
  shows "length (A |+| B) = length A + length B"
  by auto

lemma tm_comp_wf[intro]: 
  "tm_wf (A, 0); tm_wf (B, 0)  tm_wf (A |+| B, 0)"
  by (fastforce)

lemma tm_comp_step: 
  assumes unfinal: "¬ is_final (step0 c A)"
  shows "step0 c (A |+| B) = step0 c A"
proof -
  obtain s l r where eq: "c = (s, l, r)" by (metis is_final.cases) 
  have "¬ is_final (step0 (s, l, r) A)" using unfinal eq by simp
  then have "case (fetch A s (read r)) of (a, s)  s  0"
    by (auto simp add: is_final_eq)
  then have "fetch (A |+| B) s (read r) = fetch A s (read r)"
    apply (cases "read r";cases s)
    by (auto simp: tm_comp_length nth_append)
  then show "step0 c (A |+| B) = step0 c A" by (simp add: eq) 
qed

lemma tm_comp_steps:  
  assumes "¬ is_final (steps0 c A n)" 
  shows "steps0 c (A |+| B) n = steps0 c A n"
  using assms
proof(induct n)
  case 0
  then show "steps0 c (A |+| B) 0 = steps0 c A 0" by auto
next 
  case (Suc n)
  have ih: "¬ is_final (steps0 c A n)  steps0 c (A |+| B) n = steps0 c A n" by fact
  have fin: "¬ is_final (steps0 c A (Suc n))" by fact
  then have fin1: "¬ is_final (step0 (steps0 c A n) A)" 
    by (auto simp only: step_red)
  then have fin2: "¬ is_final (steps0 c A n)"
    by (metis is_final_eq step_0 surj_pair) 

  have "steps0 c (A |+| B) (Suc n) = step0 (steps0 c (A |+| B) n) (A |+| B)" 
    by (simp only: step_red)
  also have "... = step0 (steps0 c A n) (A |+| B)" by (simp only: ih[OF fin2])
  also have "... = step0 (steps0 c A n) A" by (simp only: tm_comp_step[OF fin1])
  finally show "steps0 c (A |+| B) (Suc n) = steps0 c A (Suc n)"
    by (simp only: step_red)
qed

lemma tm_comp_fetch_in_A:
  assumes h1: "fetch A s x = (a, 0)"
    and h2: "s  length A div 2" 
    and h3: "s  0"
  shows "fetch (A |+| B) s x = (a, Suc (length A div 2))"
  using h1 h2 h3
  apply(cases s;cases x)
  by(auto simp: tm_comp_length nth_append)

lemma tm_comp_exec_after_first:
  assumes h1: "¬ is_final c" 
    and h2: "step0 c A = (0, tp)"
    and h3: "fst c  length A div 2"
  shows "step0 c (A |+| B) = (Suc (length A div 2), tp)"
  using h1 h2 h3
  apply(case_tac c)
  apply(auto simp del: tm_comp.simps)
   apply(case_tac "fetch A a Bk")
   apply(simp del: tm_comp.simps)
   apply(subst tm_comp_fetch_in_A;force)
  apply(case_tac "fetch A a (hd ca)")
  apply(simp del: tm_comp.simps)
  apply(subst tm_comp_fetch_in_A)
     apply(auto)[4]
  done

lemma step_in_range: 
  assumes h1: "¬ is_final (step0 c A)"
    and h2: "tm_wf (A, 0)"
  shows "fst (step0 c A)  length A div 2"
  using h1 h2
  apply(cases c;cases "fst c";cases "hd (snd (snd c))")
  by(auto simp add: Let_def case_prod_beta')

lemma steps_in_range: 
  assumes h1: "¬ is_final (steps0 (1, tp) A stp)"
    and h2: "tm_wf (A, 0)"
  shows "fst (steps0 (1, tp) A stp)  length A div 2"
  using h1
proof(induct stp)
  case 0
  then show "fst (steps0 (1, tp) A 0)  length A div 2" using h2
    by (auto)
next
  case (Suc stp)
  have ih: "¬ is_final (steps0 (1, tp) A stp)  fst (steps0 (1, tp) A stp)  length A div 2" by fact
  have h: "¬ is_final (steps0 (1, tp) A (Suc stp))" by fact
  from ih h h2 show "fst (steps0 (1, tp) A (Suc stp))  length A div 2"
    by (metis step_in_range step_red)
qed

(* if A goes into the final state, then A |+| B will go into the first state of B *)
lemma tm_comp_next: 
  assumes a_ht: "steps0 (1, tp) A n = (0, tp')"
    and a_wf: "tm_wf (A, 0)"
  obtains n' where "steps0 (1, tp) (A |+| B) n' = (Suc (length A div 2), tp')"
proof -
  assume a: "n. steps (1, tp) (A |+| B, 0) n = (Suc (length A div 2), tp')  thesis"
  obtain stp' where fin: "¬ is_final (steps0 (1, tp) A stp')" and h: "steps0 (1, tp) A (Suc stp') = (0, tp')"
    using before_final[OF a_ht] by blast
  from fin have h1:"steps0 (1, tp) (A |+| B) stp' = steps0 (1, tp) A stp'"
    by (rule tm_comp_steps)
  from h have h2: "step0 (steps0 (1, tp) A stp') A = (0, tp')"
    by (simp only: step_red)

  have "steps0 (1, tp) (A |+| B) (Suc stp') = step0 (steps0 (1, tp) (A |+| B) stp') (A |+| B)" 
    by (simp only: step_red)
  also have "... = step0 (steps0 (1, tp) A stp') (A |+| B)" using h1 by simp
  also have "... = (Suc (length A div 2), tp')" 
    by (rule tm_comp_exec_after_first[OF fin h2 steps_in_range[OF fin a_wf]])
  finally show thesis using a by blast
qed

lemma tm_comp_fetch_second_zero:
  assumes h1: "fetch B s x = (a, 0)"
    and hs: "tm_wf (A, 0)" "s  0"
  shows "fetch (A |+| B) (s + (length A div 2)) x = (a, 0)"
  using h1 hs
  by(cases x; cases s; fastforce simp: tm_comp_length nth_append)

lemma tm_comp_fetch_second_inst:
  assumes h1: "fetch B sa x = (a, s)"
    and hs: "tm_wf (A, 0)" "sa  0" "s  0"
  shows "fetch (A |+| B) (sa + length A div 2) x = (a, s + length A div 2)"
  using h1 hs
  by(cases x; cases sa; fastforce simp: tm_comp_length nth_append)


lemma tm_comp_second:
  assumes a_wf: "tm_wf (A, 0)"
    and steps: "steps0 (1, l, r) B stp = (s', l', r')"
  shows "steps0 (Suc (length A div 2), l, r)  (A |+| B) stp 
    = (if s' = 0 then 0 else s' + length A div 2, l', r')"
  using steps
proof(induct stp arbitrary: s' l' r')
  case 0
  then show ?case by simp
next
  case (Suc stp s' l' r')
  obtain s'' l'' r'' where a: "steps0 (1, l, r) B stp = (s'', l'', r'')"
    by (metis is_final.cases)
  then have ih1: "s'' = 0  steps0 (Suc (length A div 2), l, r) (A |+| B) stp = (0, l'', r'')"
    and ih2: "s''  0  steps0 (Suc (length A div 2), l, r) (A |+| B) stp = (s'' + length A div 2, l'', r'')"
    using Suc by (auto)
  have h: "steps0 (1, l, r) B (Suc stp) = (s', l', r')" by fact

  { assume "s'' = 0"
    then have ?case using a h ih1 by (simp del: steps.simps) 
  } moreover
  { assume as: "s''  0" "s' = 0"
    from as a h 
    have "step0 (s'', l'', r'') B = (0, l', r')" by (simp del: steps.simps)
    with as have ?case
      apply(cases "fetch B s'' (read r'')")
      by (auto simp add: tm_comp_fetch_second_zero[OF _ a_wf] ih2[OF as(1)]
          simp del: tm_comp.simps steps.simps)
  } moreover
  { assume as: "s''  0" "s'  0"
    from as a h
    have "step0 (s'', l'', r'') B = (s', l', r')" by (simp del: steps.simps)
    with as have ?case
      apply(simp add: ih2[OF as(1)] del: tm_comp.simps steps.simps)
      apply(case_tac "fetch B s'' (read r'')")
      apply(auto simp add: tm_comp_fetch_second_inst[OF _ a_wf as] simp del: tm_comp.simps)
      done
  }
  ultimately show ?case by blast
qed


lemma tm_comp_final:
  assumes "tm_wf (A, 0)"  
    and "steps0 (1, l, r) B stp = (0, l', r')"
  shows "steps0 (Suc (length A div 2), l, r)  (A |+| B) stp = (0, l', r')"
  using tm_comp_second[OF assms] by (simp)

end

Theory Turing_Hoare

(* Title: thys/Turing_Hoare.thy
   Author: Jian Xu, Xingyuan Zhang, and Christian Urban
   Modifications: Sebastiaan Joosten
*)

chapter ‹Hoare Rules for TMs›

theory Turing_Hoare
  imports Turing
begin


type_synonym assert = "tape  bool"

definition 
  assert_imp :: "assert  assert  bool" ("_  _" [0, 0] 100)
  where
    "P  Q  l r. P (l, r)  Q (l, r)"

lemma refl_assert[intro, simp]:
  "P  P"
  unfolding assert_imp_def by simp

fun 
  holds_for :: "(tape  bool)  config  bool" ("_ holds'_for _" [100, 99] 100)
  where
    "P holds_for (s, l, r) = P (l, r)"  

lemma is_final_holds[simp]:
  assumes "is_final c"
  shows "Q holds_for (steps c p n) = Q holds_for c"
  using assms 
  by(induct n;cases c,auto)

(* Hoare Rules *)

(* halting case *)
definition
  Hoare_halt :: "assert  tprog0  assert  bool" ("({(1_)}/ (_)/ {(1_)})" 50)
  where
    "{P} p {Q}  (tp. P tp  (n. is_final (steps0 (1, tp) p n)  Q holds_for (steps0 (1, tp) p n)))"

(* not halting case *)
definition
  Hoare_unhalt :: "assert  tprog0  bool" ("({(1_)}/ (_)) " 50)
  where
    "{P} p   tp. P tp  ( n . ¬ (is_final (steps0 (1, tp) p n)))"


lemma Hoare_haltI:
  assumes "l r. P (l, r)  n. is_final (steps0 (1, (l, r)) p n)  Q holds_for (steps0 (1, (l, r)) p n)"
  shows "{P} p {Q}"
  unfolding Hoare_halt_def 
  using assms by auto

lemma Hoare_unhaltI:
  assumes "l r n. P (l, r)  ¬ is_final (steps0 (1, (l, r)) p n)"
  shows "{P} p "
  unfolding Hoare_unhalt_def 
  using assms by auto




text ‹
  {P} A {Q}   {Q} B {S}  A well-formed
  -----------------------------------------
  {P} A |+| B {S}
›


lemma Hoare_plus_halt [case_names A_halt B_halt A_wf]: 
  assumes A_halt : "{P} A {Q}"
    and B_halt : "{Q} B {S}"
    and A_wf : "tm_wf (A, 0)"
  shows "{P} A |+| B {S}"
proof(rule Hoare_haltI)
  fix l r
  assume h: "P (l, r)"
  then obtain n1 l' r' 
    where "is_final (steps0 (1, l, r) A n1)"  
      and a1: "Q holds_for (steps0 (1, l, r) A n1)"
      and a2: "steps0 (1, l, r) A n1 = (0, l', r')"
    using A_halt unfolding Hoare_halt_def
    by (metis is_final_eq surj_pair) 
  then obtain n2 
    where "steps0 (1, l, r) (A |+| B) n2 = (Suc (length A div 2), l', r')"
    using A_wf by (rule_tac tm_comp_next) 
  moreover
  from a1 a2 have "Q (l', r')" by (simp)
  then obtain n3 l'' r''
    where "is_final (steps0 (1, l', r') B n3)" 
      and b1: "S holds_for (steps0 (1, l', r') B n3)"
      and b2: "steps0 (1, l', r') B n3 = (0, l'', r'')"
    using B_halt unfolding Hoare_halt_def 
    by (metis is_final_eq surj_pair) 
  then have "steps0 (Suc (length A div 2), l', r')  (A |+| B) n3 = (0, l'', r'')"
    using A_wf by (rule_tac tm_comp_final) 
  ultimately show 
    "n. is_final (steps0 (1, l, r) (A |+| B) n)  S holds_for (steps0 (1, l, r) (A |+| B) n)"
    using b1 b2 by (rule_tac x = "n2 + n3" in exI) (simp)
qed

text ‹
  {P} A {Q}   {Q} B loops   A well-formed
  ------------------------------------------
          {P} A |+| B  loops
›

lemma Hoare_plus_unhalt [case_names A_halt B_unhalt A_wf]:
  assumes A_halt: "{P} A {Q}"
    and B_uhalt: "{Q} B "
    and A_wf : "tm_wf (A, 0)"
  shows "{P} (A |+| B) "
proof(rule_tac Hoare_unhaltI)
  fix n l r 
  assume h: "P (l, r)"
  then obtain n1 l' r'
    where a: "is_final (steps0 (1, l, r) A n1)" 
      and b: "Q holds_for (steps0 (1, l, r) A n1)"
      and c: "steps0 (1, l, r) A n1 = (0, l', r')"
    using A_halt unfolding Hoare_halt_def 
    by (metis is_final_eq surj_pair) 
  then obtain n2 where eq: "steps0 (1, l, r) (A |+| B) n2 = (Suc (length A div 2), l', r')"
    using A_wf by (rule_tac tm_comp_next)
  then show "¬ is_final (steps0 (1, l, r) (A |+| B) n)"
  proof(cases "n2  n")
    case True
    from b c have "Q (l', r')" by simp
    then have " n. ¬ is_final (steps0 (1, l', r') B n)  "
      using B_uhalt unfolding Hoare_unhalt_def by simp
    then have "¬ is_final (steps0 (1, l', r') B (n - n2))" by auto
    then obtain s'' l'' r'' 
      where "steps0 (1, l', r') B (n - n2) = (s'', l'', r'')" 
        and "¬ is_final (s'', l'', r'')" by (metis surj_pair)
    then have "steps0 (Suc (length A div 2), l', r') (A |+| B) (n - n2) = (s''+ length A div 2, l'', r'')"
      using A_wf by (auto dest: tm_comp_second simp del: tm_wf.simps)
    then have "¬ is_final (steps0 (1, l, r) (A |+| B) (n2 + (n  - n2)))"
      using A_wf by (simp only: steps_add eq) simp
    then show "¬ is_final (steps0 (1, l, r) (A |+| B) n)" 
      using n2  n by simp
  next 
    case False
    then obtain n3 where "n = n2 - n3"
      using diff_le_self le_imp_diff_is_add nat_le_linear
        add.commute by metis
    moreover
    with eq show "¬ is_final (steps0 (1, l, r) (A |+| B) n)"
      by (simp add: not_is_final[where ?n1.0="n2"])
  qed
qed

lemma Hoare_consequence:
  assumes "P'  P" "{P} p {Q}" "Q  Q'"
  shows "{P'} p {Q'}"
  using assms
  unfolding Hoare_halt_def assert_imp_def
  by (metis holds_for.simps surj_pair)



end

Theory Uncomputable

(* Title: thys/Uncomputable.thy
   Author: Jian Xu, Xingyuan Zhang, and Christian Urban
   Modifications: Sebastiaan Joosten
*)

chapter ‹Undeciablity of the Halting Problem›

theory Uncomputable
  imports Turing_Hoare
begin

lemma numeral:
  shows "2 = Suc 1"
    and "3 = Suc 2"
    and "4 = Suc 3" 
    and "5 = Suc 4" 
    and "6 = Suc 5" 
    and "7 = Suc 6"
    and "8 = Suc 7" 
    and "9 = Suc 8" 
    and "10 = Suc 9"
    and "11 = Suc 10"
    and "12 = Suc 11"
  by simp_all

lemma gr1_conv_Suc:"Suc 0 < mr  ( nat. mr = Suc (Suc nat))" by presburger

text ‹The Copying TM, which duplicates its input.›

definition 
  tcopy_begin :: "instr list"
  where
    "tcopy_begin  [(W0, 0), (R, 2), (R, 3), (R, 2),
                 (W1, 3), (L, 4), (L, 4), (L, 0)]"

definition 
  tcopy_loop :: "instr list"
  where
    "tcopy_loop  [(R, 0), (R, 2),  (R, 3), (W0, 2),
                 (R, 3), (R, 4), (W1, 5), (R, 4),
                 (L, 6), (L, 5), (L, 6), (L, 1)]"

definition 
  tcopy_end :: "instr list"
  where
    "tcopy_end  [(L, 0), (R, 2), (W1, 3), (L, 4),
                (R, 2), (R, 2), (L, 5), (W0, 4),
                (R, 0), (L, 5)]"

definition 
  tcopy :: "instr list"
  where
    "tcopy  (tcopy_begin |+| tcopy_loop) |+| tcopy_end"


(* tcopy_begin *)

fun 
  inv_begin0 :: "nat  tape  bool" and
  inv_begin1 :: "nat  tape  bool" and
  inv_begin2 :: "nat  tape  bool" and
  inv_begin3 :: "nat  tape  bool" and
  inv_begin4 :: "nat  tape  bool"
  where
    "inv_begin0 n (l, r) = ((n > 1  (l, r) = (Oc  (n - 2), [Oc, Oc, Bk, Oc]))    
                          (n = 1  (l, r) = ([], [Bk, Oc, Bk, Oc])))"
  | "inv_begin1 n (l, r) = ((l, r) = ([], Oc  n))"
  | "inv_begin2 n (l, r) = ( i j. i > 0  i + j = n  (l, r) = (Oc  i, Oc  j))"
  | "inv_begin3 n (l, r) = (n > 0  (l, tl r) = (Bk # Oc  n, []))"
  | "inv_begin4 n (l, r) = (n > 0  (l, r) = (Oc  n, [Bk, Oc])  (l, r) = (Oc  (n - 1), [Oc, Bk, Oc]))"

fun inv_begin :: "nat  config  bool"
  where
    "inv_begin n (s, tp) = 
        (if s = 0 then inv_begin0 n tp else
         if s = 1 then inv_begin1 n tp else
         if s = 2 then inv_begin2 n tp else
         if s = 3 then inv_begin3 n tp else
         if s = 4 then inv_begin4 n tp 
         else False)"

lemma split_head_repeat[simp]:
  "Oc # list1 = Bk  j @ list2  j = 0  Oc # list1 = list2"
  "Bk # list1 = Oc  j @ list2  j = 0  Bk # list1 = list2"
  "Bk  j @ list2 = Oc # list1  j = 0  Oc # list1 = list2"
  "Oc  j @ list2 = Bk # list1  j = 0  Bk # list1 = list2"
  by(cases j;force)+

lemma inv_begin_step_E: "0 < i; 0 < j  
  ia>0. ia + j - Suc 0 = i + j  Oc # Oc  i = Oc  ia"
  by (rule_tac x = "Suc i" in exI, simp)

lemma inv_begin_step: 
  assumes "inv_begin n cf"
    and "n > 0"
  shows "inv_begin n (step0 cf tcopy_begin)"
  using assms
  unfolding tcopy_begin_def
  apply(cases cf)
  apply(auto simp: numeral split: if_splits elim:inv_begin_step_E)
  apply(cases "hd (snd (snd cf))";cases "(snd (snd cf))",auto)
  done

lemma inv_begin_steps: 
  assumes "inv_begin n cf"
    and "n > 0"
  shows "inv_begin n (steps0 cf tcopy_begin stp)"
  apply(induct stp)
   apply(simp add: assms)
  apply(auto simp del: steps.simps)
  apply(rule_tac inv_begin_step)
   apply(simp_all add: assms)
  done

lemma begin_partial_correctness:
  assumes "is_final (steps0 (1, [], Oc  n) tcopy_begin stp)"
  shows "0 < n  {inv_begin1 n} tcopy_begin {inv_begin0 n}"
proof(rule_tac Hoare_haltI)
  fix l r
  assume h: "0 < n" "inv_begin1 n (l, r)"
  have "inv_begin n (steps0 (1, [], Oc  n) tcopy_begin stp)"
    using h by (rule_tac inv_begin_steps) (simp_all)
  then show
    "stp. is_final (steps0 (1, l, r) tcopy_begin stp)  
    inv_begin0 n holds_for steps (1, l, r) (tcopy_begin, 0) stp"
    using h assms
    apply(rule_tac x = stp in exI)
    apply(case_tac "(steps0 (1, [], Oc  n) tcopy_begin stp)", simp)
    done
qed

fun measure_begin_state :: "config  nat"
  where
    "measure_begin_state (s, l, r) = (if s = 0 then 0 else 5 - s)"

fun measure_begin_step :: "config  nat"
  where
    "measure_begin_step (s, l, r) = 
        (if s = 2 then length r else
         if s = 3 then (if r = []  r = [Bk] then 1 else 0) else
         if s = 4 then length l 
         else 0)"

definition
  "measure_begin = measures [measure_begin_state, measure_begin_step]"

lemma wf_measure_begin:
  shows "wf measure_begin" 
  unfolding measure_begin_def 
  by auto

lemma measure_begin_induct [case_names Step]: 
  "n. ¬ P (f n)  (f (Suc n), (f n))  measure_begin  n. P (f n)"
  using wf_measure_begin
  by (metis wf_iff_no_infinite_down_chain)

lemma begin_halts: 
  assumes h: "x > 0"
  shows " stp. is_final (steps0 (1, [], Oc  x) tcopy_begin stp)"
proof (induct rule: measure_begin_induct) 
  case (Step n)
  have "¬ is_final (steps0 (1, [], Oc  x) tcopy_begin n)" by fact
  moreover
  have "inv_begin x (steps0 (1, [], Oc  x) tcopy_begin n)"
    by (rule_tac inv_begin_steps) (simp_all add:  h)
  moreover
  obtain s l r where eq: "(steps0 (1, [], Oc  x) tcopy_begin n) = (s, l, r)"
    by (metis measure_begin_state.cases)
  ultimately 
  have "(step0 (s, l, r) tcopy_begin, s, l, r)  measure_begin"
    apply(auto simp: measure_begin_def tcopy_begin_def numeral split: if_splits)
    apply(subgoal_tac "r = [Oc]")
     apply(auto)
    by (metis cell.exhaust list.exhaust list.sel(3))
  then 
  show "(steps0 (1, [], Oc  x) tcopy_begin (Suc n), steps0 (1, [], Oc  x) tcopy_begin n)  measure_begin"
    using eq by (simp only: step_red)
qed

lemma begin_correct: 
  shows "0 < n  {inv_begin1 n} tcopy_begin {inv_begin0 n}"
  using begin_partial_correctness begin_halts by blast

declare tm_comp.simps [simp del] 
declare adjust.simps[simp del] 
declare shift.simps[simp del]
declare tm_wf.simps[simp del]
declare step.simps[simp del]
declare steps.simps[simp del]

(* tcopy_loop *)

fun 
  inv_loop1_loop :: "nat  tape  bool" and
  inv_loop1_exit :: "nat  tape  bool" and
  inv_loop5_loop :: "nat  tape  bool" and
  inv_loop5_exit :: "nat  tape  bool" and
  inv_loop6_loop :: "nat  tape  bool" and
  inv_loop6_exit :: "nat  tape  bool"
  where
    "inv_loop1_loop n (l, r) = ( i j. i + j + 1 = n  (l, r) = (Oci, Oc#Oc#Bkj @ Ocj)  j > 0)"
  | "inv_loop1_exit n (l, r) = (0 < n  (l, r) = ([], Bk#Oc#Bkn @ Ocn))"
  | "inv_loop5_loop x (l, r) = 
     ( i j k t. i + j = Suc x  i > 0  j > 0  k + t = j  t > 0  (l, r) = (Ock@Bkj@Oci, Oct))"
  | "inv_loop5_exit x (l, r) = 
     ( i j. i + j = Suc x  i > 0  j > 0  (l, r) = (Bk(j - 1)@Oci, Bk # Ocj))"
  | "inv_loop6_loop x (l, r) = 
     ( i j k t. i + j = Suc x  i > 0  k + t + 1 = j  (l, r) = (Bkk @ Oci, Bk(Suc t) @ Ocj))"
  | "inv_loop6_exit x (l, r) = 
     ( i j. i + j = x  j > 0  (l, r) = (Oci, Oc#Bkj @ Ocj))"

fun 
  inv_loop0 :: "nat  tape  bool" and
  inv_loop1 :: "nat  tape  bool" and
  inv_loop2 :: "nat  tape  bool" and
  inv_loop3 :: "nat  tape  bool" and
  inv_loop4 :: "nat  tape  bool" and
  inv_loop5 :: "nat  tape  bool" and
  inv_loop6 :: "nat  tape  bool"
  where
    "inv_loop0 n (l, r) =  (0 < n  (l, r) = ([Bk], Oc # Bkn @ Ocn))"
  | "inv_loop1 n (l, r) = (inv_loop1_loop n (l, r)  inv_loop1_exit n (l, r))"
  | "inv_loop2 n (l, r) = ( i j any. i + j = n  n > 0  i > 0  j > 0  (l, r) = (Oci, any#Bkj@Ocj))"
  | "inv_loop3 n (l, r) = 
     ( i j k t. i + j = n  i > 0  j > 0   k + t = Suc j  (l, r) = (Bkk@Oci, Bkt@Ocj))"
  | "inv_loop4 n (l, r) = 
     ( i j k t. i + j = n  i > 0  j > 0   k + t = j  (l, r) = (Ock @ Bk(Suc j)@Oci, Oct))"
  | "inv_loop5 n (l, r) = (inv_loop5_loop n (l, r)  inv_loop5_exit n (l, r))"
  | "inv_loop6 n (l, r) = (inv_loop6_loop n (l, r)  inv_loop6_exit n (l, r))"

fun inv_loop :: "nat  config  bool"
  where
    "inv_loop x (s, l, r) = 
         (if s = 0 then inv_loop0 x (l, r)
          else if s = 1 then inv_loop1 x (l, r)
          else if s = 2 then inv_loop2 x (l, r)
          else if s = 3 then inv_loop3 x (l, r)
          else if s = 4 then inv_loop4 x (l, r)
          else if s = 5 then inv_loop5 x (l, r)
          else if s = 6 then inv_loop6 x (l, r)
          else False)"

declare inv_loop.simps[simp del] inv_loop1.simps[simp del]
  inv_loop2.simps[simp del] inv_loop3.simps[simp del] 
  inv_loop4.simps[simp del] inv_loop5.simps[simp del] 
  inv_loop6.simps[simp del]

lemma Bk_no_Oc_repeatE[elim]: "Bk # list = Oc  t  RR"
  by (cases t, auto)

lemma inv_loop3_Bk_empty_via_2[elim]: "0 < x; inv_loop2 x (b, [])  inv_loop3 x (Bk # b, [])"
  by (auto simp: inv_loop2.simps inv_loop3.simps)

lemma inv_loop3_Bk_empty[elim]: "0 < x; inv_loop3 x (b, [])  inv_loop3 x (Bk # b, [])"
  by (auto simp: inv_loop3.simps)

lemma inv_loop5_Oc_empty_via_4[elim]: "0 < x; inv_loop4 x (b, [])  inv_loop5 x (b, [Oc])"
  by(auto simp: inv_loop4.simps inv_loop5.simps;force)

lemma inv_loop1_Bk[elim]: "0 < x; inv_loop1 x (b, Bk # list)  list = Oc # Bk  x @ Oc  x"
  by (auto simp: inv_loop1.simps)

lemma inv_loop3_Bk_via_2[elim]: "0 < x; inv_loop2 x (b, Bk # list)  inv_loop3 x (Bk # b, list)"
  by(auto simp: inv_loop2.simps inv_loop3.simps;force)

lemma inv_loop3_Bk_move[elim]: "0 < x; inv_loop3 x (b, Bk # list)  inv_loop3 x (Bk # b, list)"
  apply(auto simp: inv_loop3.simps)
   apply (rename_tac i j k t)
   apply(rule_tac [!] x = i in exI, 
      rule_tac [!] x = j in exI, simp_all)
   apply(case_tac [!] t, auto)
  done

lemma inv_loop5_Oc_via_4_Bk[elim]: "0 < x; inv_loop4 x (b, Bk # list)  inv_loop5 x (b, Oc # list)"
  by (auto simp: inv_loop4.simps inv_loop5.simps)

lemma inv_loop6_Bk_via_5[elim]: "0 < x; inv_loop5 x ([], Bk # list)  inv_loop6 x ([], Bk # Bk # list)"
  by (auto simp: inv_loop6.simps inv_loop5.simps)

lemma inv_loop5_loop_no_Bk[simp]: "inv_loop5_loop x (b, Bk # list) = False"
  by (auto simp: inv_loop5.simps)

lemma inv_loop6_exit_no_Bk[simp]: "inv_loop6_exit x (b, Bk # list) = False"
  by (auto simp: inv_loop6.simps)

declare inv_loop5_loop.simps[simp del]  inv_loop5_exit.simps[simp del]
  inv_loop6_loop.simps[simp del]  inv_loop6_exit.simps[simp del]

lemma inv_loop6_loopBk_via_5[elim]:"0 < x; inv_loop5_exit x (b, Bk # list); b  []; hd b = Bk 
           inv_loop6_loop x (tl b, Bk # Bk # list)"
  apply(simp only: inv_loop5_exit.simps inv_loop6_loop.simps )
  apply(erule_tac exE)+
  apply(rename_tac i j)
  apply(rule_tac x = i in exI, 
      rule_tac x = j in exI,
      rule_tac x = "j - Suc (Suc 0)" in exI, 
      rule_tac x = "Suc 0" in exI, auto)
   apply(case_tac [!] j, simp_all)
   apply(case_tac [!] "j-1", simp_all)
  done

lemma inv_loop6_loop_no_Oc_Bk[simp]: "inv_loop6_loop x (b, Oc # Bk # list) = False"
  by (auto simp: inv_loop6_loop.simps)

lemma inv_loop6_exit_Oc_Bk_via_5[elim]: "x > 0; inv_loop5_exit x (b, Bk # list); b  []; hd b = Oc  
  inv_loop6_exit x (tl b, Oc # Bk # list)"
  apply(simp only: inv_loop5_exit.simps inv_loop6_exit.simps)
  apply(erule_tac exE)+
  apply(rule_tac x = "x - 1" in exI, rule_tac x = 1 in exI, simp)
  apply(rename_tac i j)
  apply(case_tac j;case_tac "j-1", auto)
  done

lemma inv_loop6_Bk_tail_via_5[elim]: "0 < x; inv_loop5 x (b, Bk # list); b  []  inv_loop6 x (tl b, hd b # Bk # list)"
  apply(simp add: inv_loop5.simps inv_loop6.simps)
  apply(cases "hd b", simp_all, auto)
  done

lemma inv_loop6_loop_Bk_Bk_drop[elim]: "0 < x; inv_loop6_loop x (b, Bk # list); b  []; hd b = Bk
               inv_loop6_loop x (tl b, Bk # Bk # list)"
  apply(simp only: inv_loop6_loop.simps)
  apply(erule_tac exE)+
  apply(rename_tac i j k t)
  apply(rule_tac x = i in exI, rule_tac x = j in exI, 
      rule_tac x = "k - 1" in exI, rule_tac x = "Suc t" in exI, auto)
   apply(case_tac [!] k, auto)
  done

lemma inv_loop6_exit_Oc_Bk_via_loop6[elim]: "0 < x; inv_loop6_loop x (b, Bk # list); b  []; hd b = Oc 
         inv_loop6_exit x (tl b, Oc # Bk # list)"
  apply(simp only: inv_loop6_loop.simps inv_loop6_exit.simps)
  apply(erule_tac exE)+
  apply(rename_tac i j k t)
  apply(rule_tac x = "i - 1" in exI, rule_tac x = j in exI, auto)
   apply(case_tac [!] k, auto)
  done

lemma inv_loop6_Bk_tail[elim]: "0 < x; inv_loop6 x (b, Bk # list); b  []  inv_loop6 x (tl b, hd b # Bk # list)"
  apply(simp add: inv_loop6.simps)
  apply(case_tac "hd b", simp_all, auto)
  done

lemma inv_loop2_Oc_via_1[elim]: "0 < x; inv_loop1 x (b, Oc # list)  inv_loop2 x (Oc # b, list)"
  apply(auto simp: inv_loop1.simps inv_loop2.simps,force)
  done

lemma inv_loop2_Bk_via_Oc[elim]: "0 < x; inv_loop2 x (b, Oc # list)  inv_loop2 x (b, Bk # list)"
  by (auto simp: inv_loop2.simps)

lemma inv_loop4_Oc_via_3[elim]: "0 < x; inv_loop3 x (b, Oc # list)  inv_loop4 x (Oc # b, list)"
  apply(auto simp: inv_loop3.simps inv_loop4.simps)
   apply(rename_tac i j)
   apply(rule_tac [!] x = i in exI, auto)
   apply(rule_tac [!] x = "Suc 0" in exI, rule_tac [!] x = "j - 1" in exI)
   apply(case_tac [!] j, auto)
  done

lemma inv_loop4_Oc_move[elim]:
  assumes "0 < x" "inv_loop4 x (b, Oc # list)"
  shows "inv_loop4 x (Oc # b, list)"
proof -
  from assms[unfolded inv_loop4.simps] obtain i j k t where
    "i + j = x"
    "0 < i" "0 < j" "k + t = j" "(b, Oc # list) = (Oc  k @ Bk  Suc j @ Oc  i, Oc  t)"
    by auto  
  thus ?thesis unfolding inv_loop4.simps
    apply(rule_tac [!] x = "i" in exI,rule_tac [!] x = "j" in exI)
    apply(rule_tac [!] x = "Suc k" in exI,rule_tac [!] x = "t - 1" in exI)
    by(cases t,auto)
qed

lemma inv_loop5_exit_no_Oc[simp]: "inv_loop5_exit x (b, Oc # list) = False"
  by (auto simp: inv_loop5_exit.simps)

lemma inv_loop5_exit_Bk_Oc_via_loop[elim]: " inv_loop5_loop x (b, Oc # list); b  []; hd b = Bk
   inv_loop5_exit x (tl b, Bk # Oc # list)"
  apply(simp only: inv_loop5_loop.simps inv_loop5_exit.simps)
  apply(erule_tac exE)+
  apply(rename_tac i j k t)
  apply(rule_tac x = i in exI)
  apply(case_tac k, auto)
  done

lemma inv_loop5_loop_Oc_Oc_drop[elim]: "inv_loop5_loop x (b, Oc # list); b  []; hd b = Oc 
            inv_loop5_loop x (tl b, Oc # Oc # list)"
  apply(simp only:  inv_loop5_loop.simps)
  apply(erule_tac exE)+
  apply(rename_tac i j k t)
  apply(rule_tac x = i in exI, rule_tac x = j in exI)
  apply(rule_tac x = "k - 1" in exI, rule_tac x = "Suc t" in exI)
  apply(case_tac k, auto)
  done

lemma inv_loop5_Oc_tl[elim]: "inv_loop5 x (b, Oc # list); b  []  inv_loop5 x (tl b, hd b # Oc # list)"
  apply(simp add: inv_loop5.simps)
  apply(cases "hd b", simp_all, auto)
  done

lemma inv_loop1_Bk_Oc_via_6[elim]: "0 < x; inv_loop6 x ([], Oc # list)  inv_loop1 x ([], Bk # Oc # list)"
  by(auto simp: inv_loop6.simps inv_loop1.simps inv_loop6_loop.simps inv_loop6_exit.simps)

lemma inv_loop1_Oc_via_6[elim]: "0 < x; inv_loop6 x (b, Oc # list); b  [] 
            inv_loop1 x (tl b, hd b # Oc # list)"
  by(auto simp: inv_loop6.simps inv_loop1.simps inv_loop6_loop.simps inv_loop6_exit.simps)


lemma inv_loop_nonempty[simp]:
  "inv_loop1 x (b, []) = False"
  "inv_loop2 x ([], b) = False"
  "inv_loop2 x (l', []) = False"
  "inv_loop3 x (b, []) = False"
  "inv_loop4 x ([], b) = False"
  "inv_loop5 x ([], list) = False"
  "inv_loop6 x ([], Bk # xs) = False"
  by (auto simp: inv_loop1.simps inv_loop2.simps inv_loop3.simps inv_loop4.simps 
      inv_loop5.simps inv_loop6.simps inv_loop5_exit.simps inv_loop5_loop.simps
      inv_loop6_loop.simps)

lemma inv_loop_nonemptyE[elim]:
  "inv_loop5 x (b, [])  RR" "inv_loop6 x (b, [])  RR" 
  "inv_loop1 x (b, Bk # list)  b = []"
  by (auto simp: inv_loop4.simps inv_loop5.simps inv_loop5_exit.simps inv_loop5_loop.simps
      inv_loop6.simps inv_loop6_exit.simps inv_loop6_loop.simps inv_loop1.simps)

lemma inv_loop6_Bk_Bk_drop[elim]: "inv_loop6 x ([], Bk # list)  inv_loop6 x ([], Bk # Bk # list)"
  by (simp)

lemma inv_loop_step: 
  "inv_loop x cf; x > 0  inv_loop x (step cf (tcopy_loop, 0))"
  apply(cases cf, cases "snd (snd cf)"; cases "hd (snd (snd cf))")
     apply(auto simp: inv_loop.simps step.simps tcopy_loop_def numeral split: if_splits)
  done

lemma inv_loop_steps:
  "inv_loop x cf; x > 0  inv_loop x (steps cf (tcopy_loop, 0) stp)"
  apply(induct stp, simp add: steps.simps, simp)
  apply(erule_tac inv_loop_step, simp)
  done

fun loop_stage :: "config  nat"
  where
    "loop_stage (s, l, r) = (if s = 0 then 0
                           else (Suc (length (takeWhile (λa. a = Oc) (rev l @ r)))))"

fun loop_state :: "config  nat"
  where
    "loop_state (s, l, r) = (if s = 2  hd r = Oc then 0
                           else if s = 1 then 1
                           else 10 - s)"

fun loop_step :: "config  nat"
  where
    "loop_step (s, l, r) = (if s = 3 then length r
                          else if s = 4 then length r
                          else if s = 5 then length l 
                          else if s = 6 then length l
                          else 0)"

definition measure_loop :: "(config × config) set"
  where
    "measure_loop = measures [loop_stage, loop_state, loop_step]"

lemma wf_measure_loop: "wf measure_loop"
  unfolding measure_loop_def
  by (auto)

lemma measure_loop_induct [case_names Step]: 
  "n. ¬ P (f n)  (f (Suc n), (f n))  measure_loop  n. P (f n)"
  using wf_measure_loop
  by (metis wf_iff_no_infinite_down_chain)

lemma inv_loop4_not_just_Oc[elim]: 
  "inv_loop4 x (l', []);
  length (takeWhile (λa. a = Oc) (rev l' @ [Oc]))  
  length (takeWhile (λa. a = Oc) (rev l'))
   RR"
  "inv_loop4 x (l', Bk # list);
   length (takeWhile (λa. a = Oc) (rev l' @ Oc # list))  
    length (takeWhile (λa. a = Oc) (rev l' @ Bk # list))
     RR"
   apply(auto simp: inv_loop4.simps)
  apply(rename_tac i j)
  apply(case_tac [!] j, simp_all add: List.takeWhile_tail)
  done

lemma takeWhile_replicate_append: 
  "P a  takeWhile P (ax @ ys) = ax @ takeWhile P ys"
  by (induct x, auto)

lemma takeWhile_replicate: 
  "P a  takeWhile P (ax) = ax"
  by (induct x, auto)

lemma inv_loop5_Bk_E[elim]: 
  "inv_loop5 x (l', Bk # list); l'  []; 
   length (takeWhile (λa. a = Oc) (rev (tl l') @ hd l' # Bk # list)) 
   length (takeWhile (λa. a = Oc) (rev l' @ Bk # list))
    RR"
  apply(cases "length list";cases "length list - 1"
      ,auto simp: inv_loop5.simps inv_loop5_exit.simps
      takeWhile_replicate_append takeWhile_replicate)
   apply(cases "length list - 2"; force simp add: List.takeWhile_tail)+
  done

lemma inv_loop1_hd_Oc[elim]: "inv_loop1 x (l', Oc # list)  hd list = Oc"
  by (auto simp: inv_loop1.simps)

lemma inv_loop6_not_just_Bk[dest!]: 
  "length (takeWhile P (rev (tl l') @ hd l' # list))  
  length (takeWhile P (rev l' @ list))
   l' = []"
  apply(cases l', simp_all)
  done

lemma inv_loop2_OcE[elim]:
  "inv_loop2 x (l', Oc # list); l'  []  
  length (takeWhile (λa. a = Oc) (rev l' @ Bk # list)) <
  length (takeWhile (λa. a = Oc) (rev l' @ Oc # list))"
  apply(auto simp: inv_loop2.simps takeWhile_tail takeWhile_replicate_append
      takeWhile_replicate)
  done

lemma loop_halts: 
  assumes h: "n > 0" "inv_loop n (1, l, r)"
  shows " stp. is_final (steps0 (1, l, r) tcopy_loop stp)"
proof (induct rule: measure_loop_induct) 
  case (Step stp)
  have "¬ is_final (steps0 (1, l, r) tcopy_loop stp)" by fact
  moreover
  have "inv_loop n (steps0 (1, l, r) tcopy_loop stp)"
    by (rule_tac inv_loop_steps) (simp_all only: h)
  moreover
  obtain s l' r' where eq: "(steps0 (1, l, r) tcopy_loop stp) = (s, l', r')"
    by (metis measure_begin_state.cases)
  ultimately 
  have "(step0 (s, l', r') tcopy_loop, s, l', r')  measure_loop"
    using h(1)
    apply(cases r';cases "hd r'")
       apply(auto simp: inv_loop.simps step.simps tcopy_loop_def numeral measure_loop_def split: if_splits)
    done
  then 
  show "(steps0 (1, l, r) tcopy_loop (Suc stp), steps0 (1, l, r) tcopy_loop stp)  measure_loop"
    using eq by (simp only: step_red)
qed

lemma loop_correct:
  assumes "0 < n"
  shows "{inv_loop1 n} tcopy_loop {inv_loop0 n}"
  using assms
proof(rule_tac Hoare_haltI)
  fix l r
  assume h: "0 < n" "inv_loop1 n (l, r)"
  then obtain stp where k: "is_final (steps0 (1, l, r) tcopy_loop stp)" 
    using loop_halts
    apply(simp add: inv_loop.simps)
    apply(blast)
    done
  moreover
  have "inv_loop n (steps0 (1, l, r) tcopy_loop stp)"
    using h 
    by (rule_tac inv_loop_steps) (simp_all add: inv_loop.simps)
  ultimately show
    "stp. is_final (steps0 (1, l, r) tcopy_loop stp)  
    inv_loop0 n holds_for steps0 (1, l, r) tcopy_loop stp"
    using h(1) 
    apply(rule_tac x = stp in exI)
    apply(case_tac "(steps0 (1, l, r) tcopy_loop stp)")
    apply(simp add: inv_loop.simps)
    done
qed




(* tcopy_end *)

fun
  inv_end5_loop :: "nat  tape  bool" and
  inv_end5_exit :: "nat  tape  bool" 
  where  
    "inv_end5_loop x (l, r) = 
     ( i j. i + j = x  x > 0  j > 0  l = Oci @ [Bk]  r = Ocj @ Bk # Ocx)"
  | "inv_end5_exit x (l, r) = (x > 0  l = []  r = Bk # Ocx @ Bk # Ocx)"

fun 
  inv_end0 :: "nat  tape   bool" and
  inv_end1 :: "nat  tape  bool" and
  inv_end2 :: "nat  tape  bool" and
  inv_end3 :: "nat  tape  bool" and
  inv_end4 :: "nat  tape  bool" and 
  inv_end5 :: "nat  tape  bool" 
  where
    "inv_end0 n (l, r) = (n > 0  (l, r) = ([Bk], Ocn @ Bk # Ocn))"
  | "inv_end1 n (l, r) = (n > 0  (l, r) = ([Bk], Oc # Bkn @ Ocn))"
  | "inv_end2 n (l, r) = ( i j. i + j = Suc n  n > 0  l = Oci @ [Bk]  r = Bkj @ Ocn)"
  | "inv_end3 n (l, r) =
     ( i j. n > 0  i + j = n  l = Oci @ [Bk]  r = Oc # Bkj@ Ocn)"
  | "inv_end4 n (l, r) = ( any. n > 0  l = Ocn @ [Bk]  r = any#Ocn)"
  | "inv_end5 n (l, r) = (inv_end5_loop n (l, r)  inv_end5_exit n (l, r))"

fun 
  inv_end :: "nat  config  bool"
  where
    "inv_end n (s, l, r) = (if s = 0 then inv_end0 n (l, r)
                          else if s = 1 then inv_end1 n (l, r)
                          else if s = 2 then inv_end2 n (l, r)
                          else if s = 3 then inv_end3 n (l, r)
                          else if s = 4 then inv_end4 n (l, r)
                          else if s = 5 then inv_end5 n (l, r)
                          else False)"

declare inv_end.simps[simp del] inv_end1.simps[simp del]
  inv_end0.simps[simp del] inv_end2.simps[simp del]
  inv_end3.simps[simp del] inv_end4.simps[simp del]
  inv_end5.simps[simp del]

lemma inv_end_nonempty[simp]:
  "inv_end1 x (b, []) = False"
  "inv_end1 x ([], list) = False"
  "inv_end2 x (b, []) = False"
  "inv_end3 x (b, []) = False"
  "inv_end4 x (b, []) = False"
  "inv_end5 x (b, []) = False"
  "inv_end5 x ([], Oc # list) = False"
  by (auto simp: inv_end1.simps inv_end2.simps inv_end3.simps inv_end4.simps inv_end5.simps)

lemma inv_end0_Bk_via_1[elim]: "0 < x; inv_end1 x (b, Bk # list); b  []
   inv_end0 x (tl b, hd b # Bk # list)"
  by (auto simp: inv_end1.simps inv_end0.simps)

lemma inv_end3_Oc_via_2[elim]: "0 < x; inv_end2 x (b, Bk # list) 
   inv_end3 x (b, Oc # list)"
  apply(auto simp: inv_end2.simps inv_end3.simps)
  by (metis Cons_replicate_eq One_nat_def Suc_inject Suc_pred add_Suc_right cell.distinct(1)
      empty_replicate list.sel(3) neq0_conv self_append_conv2 tl_append2 tl_replicate)

lemma inv_end2_Bk_via_3[elim]: "0 < x; inv_end3 x (b, Bk # list)  inv_end2 x (Bk # b, list)"
  by (auto simp: inv_end2.simps inv_end3.simps)

lemma inv_end5_Bk_via_4[elim]: "0 < x; inv_end4 x ([], Bk # list)  
  inv_end5 x ([], Bk # Bk # list)"
  by (auto simp: inv_end4.simps inv_end5.simps)

lemma inv_end5_Bk_tail_via_4[elim]: "0 < x; inv_end4 x (b, Bk # list); b  []  
  inv_end5 x (tl b, hd b # Bk # list)"
  apply(auto simp: inv_end4.simps inv_end5.simps)
  apply(rule_tac x = 1 in exI, simp)
  done

lemma inv_end0_Bk_via_5[elim]: "0 < x; inv_end5 x (b, Bk # list)  inv_end0 x (Bk # b, list)"
  by(auto simp: inv_end5.simps inv_end0.simps gr0_conv_Suc)

lemma inv_end2_Oc_via_1[elim]: "0 < x; inv_end1 x (b, Oc # list)  inv_end2 x (Oc # b, list)"
  by (auto simp: inv_end1.simps inv_end2.simps)

lemma inv_end4_Bk_Oc_via_2[elim]: "0 < x; inv_end2 x ([], Oc # list) 
               inv_end4 x ([], Bk # Oc # list)"
  by (auto simp: inv_end2.simps inv_end4.simps)

lemma inv_end4_Oc_via_2[elim]:  "0 < x; inv_end2 x (b, Oc # list); b  [] 
  inv_end4 x (tl b, hd b # Oc # list)"
  by(auto simp: inv_end2.simps inv_end4.simps gr0_conv_Suc)

lemma inv_end2_Oc_via_3[elim]: "0 < x; inv_end3 x (b, Oc # list)  inv_end2 x (Oc # b, list)"
  by (auto simp: inv_end2.simps inv_end3.simps)

lemma inv_end4_Bk_via_Oc[elim]: "0 < x; inv_end4 x (b, Oc # list)  inv_end4 x (b, Bk # list)"
  by (auto simp: inv_end2.simps inv_end4.simps)

lemma inv_end5_Bk_drop_Oc[elim]: "0 < x; inv_end5 x ([], Oc # list)  inv_end5 x ([], Bk # Oc # list)"
  by (auto simp: inv_end2.simps inv_end5.simps)

declare inv_end5_loop.simps[simp del]
  inv_end5_exit.simps[simp del]

lemma inv_end5_exit_no_Oc[simp]: "inv_end5_exit x (b, Oc # list) = False"
  by (auto simp: inv_end5_exit.simps)

lemma inv_end5_loop_no_Bk_Oc[simp]: "inv_end5_loop x (tl b, Bk # Oc # list) = False"
  by (auto simp: inv_end5_loop.simps)

lemma inv_end5_exit_Bk_Oc_via_loop[elim]:
  "0 < x; inv_end5_loop x (b, Oc # list); b  []; hd b = Bk 
  inv_end5_exit x (tl b, Bk # Oc # list)"
  apply(auto simp: inv_end5_loop.simps inv_end5_exit.simps)
  using hd_replicate apply fastforce
  by (metis cell.distinct(1) hd_append2 hd_replicate list.sel(3) self_append_conv2
      split_head_repeat(2))

lemma inv_end5_loop_Oc_Oc_drop[elim]: 
  "0 < x; inv_end5_loop x (b, Oc # list); b  []; hd b = Oc 
  inv_end5_loop x (tl b, Oc # Oc # list)"
  apply(simp only: inv_end5_loop.simps inv_end5_exit.simps)
  apply(erule_tac exE)+
  apply(rename_tac i j)
  apply(rule_tac x = "i - 1" in exI, 
      rule_tac x = "Suc j" in exI, auto)
   apply(case_tac [!] i, simp_all)
  done

lemma inv_end5_Oc_tail[elim]: "0 < x; inv_end5 x (b, Oc # list); b  []  
  inv_end5 x (tl b, hd b # Oc # list)"
  apply(simp add: inv_end2.simps inv_end5.simps)
  apply(case_tac "hd b", simp_all, auto)
  done

lemma inv_end_step:
  "x > 0; inv_end x cf  inv_end x (step cf (tcopy_end, 0))"
  apply(cases cf, cases "snd (snd cf)"; cases "hd (snd (snd cf))")
     apply(auto simp: inv_end.simps step.simps tcopy_end_def numeral split: if_splits)
  done

lemma inv_end_steps:
  "x > 0; inv_end x cf  inv_end x (steps cf (tcopy_end, 0) stp)"
  apply(induct stp, simp add:steps.simps, simp)
  apply(erule_tac inv_end_step, simp)
  done

fun end_state :: "config  nat"
  where
    "end_state (s, l, r) = 
       (if s = 0 then 0
        else if s = 1 then 5
        else if s = 2  s = 3 then 4
        else if s = 4 then 3 
        else if s = 5 then 2
        else 0)"

fun end_stage :: "config  nat"
  where
    "end_stage (s, l, r) = 
          (if s = 2  s = 3 then (length r) else 0)"

fun end_step :: "config  nat"
  where
    "end_step (s, l, r) = 
         (if s = 4 then (if hd r = Oc then 1 else 0)
          else if s = 5 then length l
          else if s = 2 then 1
          else if s = 3 then 0
          else 0)"

definition end_LE :: "(config × config) set"
  where
    "end_LE = measures [end_state, end_stage, end_step]"

lemma wf_end_le: "wf end_LE"
  unfolding end_LE_def by auto

lemma halt_lemma: 
  "wf LE; n. (¬ P (f n)  (f (Suc n), (f n))  LE)  n. P (f n)"
  by (metis wf_iff_no_infinite_down_chain)

lemma end_halt: 
  "x > 0; inv_end x (Suc 0, l, r)  
       stp. is_final (steps (Suc 0, l, r) (tcopy_end, 0) stp)"
proof(rule halt_lemma[OF wf_end_le])
  assume great: "0 < x"
    and inv_start: "inv_end x (Suc 0, l, r)"
  show "n. ¬ is_final (steps (Suc 0, l, r) (tcopy_end, 0) n)  
    (steps (Suc 0, l, r) (tcopy_end, 0) (Suc n), steps (Suc 0, l, r) (tcopy_end, 0) n)  end_LE"
  proof(rule_tac allI, rule_tac impI)
    fix n
    assume notfinal: "¬ is_final (steps (Suc 0, l, r) (tcopy_end, 0) n)"
    obtain s' l' r' where d: "steps (Suc 0, l, r) (tcopy_end, 0) n = (s', l', r')"
      apply(case_tac "steps (Suc 0, l, r) (tcopy_end, 0) n", auto)
      done
    hence "inv_end x (s', l', r')  s'  0"
      using great inv_start notfinal
      apply(drule_tac stp = n in inv_end_steps, auto)
      done
    hence "(step (s', l', r') (tcopy_end, 0), s', l', r')  end_LE"
      apply(cases r'; cases "hd r'")
         apply(auto simp: inv_end.simps step.simps tcopy_end_def numeral end_LE_def split: if_splits)
      done
    thus "(steps (Suc 0, l, r) (tcopy_end, 0) (Suc n), 
      steps (Suc 0, l, r) (tcopy_end, 0) n)  end_LE"
      using d
      by simp
  qed
qed

lemma end_correct:
  "n > 0  {inv_end1 n} tcopy_end {inv_end0 n}"
proof(rule_tac Hoare_haltI)
  fix l r
  assume h: "0 < n"
    "inv_end1 n (l, r)"
  then have " stp. is_final (steps0 (1, l, r) tcopy_end stp)"
    by (simp add: end_halt inv_end.simps)
  then obtain stp where "is_final (steps0 (1, l, r) tcopy_end stp)" ..
  moreover have "inv_end n (steps0 (1, l, r) tcopy_end stp)"
    apply(rule_tac inv_end_steps)
    using h by(simp_all add: inv_end.simps)
  ultimately show
    "stp. is_final (steps (1, l, r) (tcopy_end, 0) stp)  
    inv_end0 n holds_for steps (1, l, r) (tcopy_end, 0) stp"        
    using h
    apply(rule_tac x = stp in exI)
    apply(cases "(steps0 (1, l, r) tcopy_end stp)") 
    apply(simp add: inv_end.simps)
    done
qed

(* tcopy *)

lemma tm_wf_tcopy[intro]:
  "tm_wf (tcopy_begin, 0)"
  "tm_wf (tcopy_loop, 0)"
  "tm_wf (tcopy_end, 0)"
  by (auto simp: tm_wf.simps tcopy_end_def tcopy_loop_def tcopy_begin_def)

lemma tcopy_correct1: 
  assumes "0 < x"
  shows "{inv_begin1 x} tcopy {inv_end0 x}"
proof -
  have "{inv_begin1 x} tcopy_begin {inv_begin0 x}"
    by (metis assms begin_correct) 
  moreover 
  have "inv_begin0 x  inv_loop1 x"
    unfolding assert_imp_def
    unfolding inv_begin0.simps inv_loop1.simps
    unfolding inv_loop1_loop.simps inv_loop1_exit.simps
    apply(auto simp add: numeral Cons_eq_append_conv)
    by (rule_tac x = "Suc 0" in exI, auto)
  ultimately have "{inv_begin1 x} tcopy_begin {inv_loop1 x}"
    by (rule_tac Hoare_consequence) (auto)
  moreover
  have "{inv_loop1 x} tcopy_loop {inv_loop0 x}"
    by (metis assms loop_correct) 
  ultimately 
  have "{inv_begin1 x} (tcopy_begin |+| tcopy_loop) {inv_loop0 x}"
    by (rule_tac Hoare_plus_halt) (auto)
  moreover 
  have "{inv_end1 x} tcopy_end {inv_end0 x}"
    by (metis assms end_correct) 
  moreover 
  have "inv_loop0 x = inv_end1 x"
    by(auto simp: inv_end1.simps inv_loop1.simps assert_imp_def)
  ultimately 
  show "{inv_begin1 x} tcopy {inv_end0 x}"
    unfolding tcopy_def
    by (rule_tac Hoare_plus_halt) (auto)
qed

abbreviation (input)
  "pre_tcopy n  λtp. tp = ([]::cell list, Oc  (Suc n))"
abbreviation (input)
  "post_tcopy n  λtp. tp= ([Bk], <(n, n::nat)>)"

lemma tcopy_correct:
  shows "{pre_tcopy n} tcopy {post_tcopy n}"
proof -
  have "{inv_begin1 (Suc n)} tcopy {inv_end0 (Suc n)}"
    by (rule tcopy_correct1) (simp)
  moreover
  have "pre_tcopy n = inv_begin1 (Suc n)"
    by (auto)
  moreover
  have "inv_end0 (Suc n) = post_tcopy n"
    unfolding fun_eq_iff
    by (auto simp add: inv_end0.simps tape_of_nat_def tape_of_prod_def)
  ultimately
  show "{pre_tcopy n} tcopy {post_tcopy n}" 
    by simp
qed


section ‹The {\em Dithering} Turing Machine›

text ‹
  The {\em Dithering} TM, when the input is 1›, it will loop forever, otherwise, it will
  terminate.
›

definition dither :: "instr list"
  where
    "dither  [(W0, 1), (R, 2), (L, 1), (L, 0)] "

(* invariants of dither *)
abbreviation (input)
  "dither_halt_inv  λtp. k. tp = (Bk  k, <1::nat>)"

abbreviation (input)
  "dither_unhalt_inv  λtp. k. tp = (Bk  k, <0::nat>)"

lemma dither_loops_aux: 
  "(steps0 (1, Bk  m, [Oc]) dither stp = (1, Bk  m, [Oc]))  
   (steps0 (1, Bk  m, [Oc]) dither stp = (2, Oc # Bk  m, []))"
  apply(induct stp)
   apply(auto simp: steps.simps step.simps dither_def numeral)
  done

lemma dither_loops:
  shows "{dither_unhalt_inv} dither " 
  apply(rule Hoare_unhaltI)
  using dither_loops_aux
  apply(auto simp add: numeral tape_of_nat_def)
  by (metis Suc_neq_Zero is_final_eq)

lemma dither_halts_aux: 
  shows "steps0 (1, Bk  m, [Oc, Oc]) dither 2 = (0, Bk  m, [Oc, Oc])"
  unfolding dither_def
  by (simp add: steps.simps step.simps numeral)

lemma dither_halts:
  shows "{dither_halt_inv} dither {dither_halt_inv}" 
  apply(rule Hoare_haltI)
  using dither_halts_aux
  apply(auto simp add: tape_of_nat_def)
  by (metis (lifting, mono_tags) holds_for.simps is_final_eq)


section ‹The diagnal argument below shows the undecidability of Halting problem›

text halts tp x› means TM tp› terminates on input x›
  and the final configuration is standard.
›

definition halts :: "tprog0  nat list  bool"
  where
    "halts p ns  {(λtp. tp = ([], <ns>))} p {(λtp. (k n l. tp = (Bk  k,  <n::nat> @ Bk  l)))}"

lemma tm_wf0_tcopy[intro, simp]: "tm_wf0 tcopy"
  by (auto simp: tcopy_def)

lemma tm_wf0_dither[intro, simp]: "tm_wf0 dither"
  by (auto simp: tm_wf.simps dither_def)

text ‹
  The following locale specifies that TM H› can be used to solve 
  the {\em Halting Problem} and False› is going to be derived 
  under this locale. Therefore, the undecidability of {\em Halting Problem}
  is established. 
›

locale uncomputable = 
  (* The coding function of TM, interestingly, the detailed definition of this 
  funciton @{text "code"} does not affect the final result. *)
  fixes code :: "instr list  nat" 
    (* 
  The TM @{text "H"} is the one which is assummed being able to solve the Halting problem.
  *)
    and H :: "instr list"
  assumes h_wf[intro]: "tm_wf0 H"
    (*
  The following two assumptions specifies that @{text "H"} does solve the Halting problem.
  *)
    and h_case: 
    " M ns. halts M ns  {(λtp. tp = ([Bk], <(code M, ns)>))} H {(λtp. k. tp = (Bk  k, <0::nat>))}"
    and nh_case: 
    " M ns. ¬ halts M ns  {(λtp. tp = ([Bk], <(code M, ns)>))} H {(λtp. k. tp = (Bk  k, <1::nat>))}"
begin

(* invariants for H *)
abbreviation (input)
  "pre_H_inv M ns  λtp. tp = ([Bk], <(code M, ns::nat list)>)"

abbreviation (input)
  "post_H_halt_inv  λtp. k. tp = (Bk  k, <1::nat>)"

abbreviation (input)
  "post_H_unhalt_inv  λtp. k. tp = (Bk  k, <0::nat>)"


lemma H_halt_inv:
  assumes "¬ halts M ns" 
  shows "{pre_H_inv M ns} H {post_H_halt_inv}"
  using assms nh_case by auto

lemma H_unhalt_inv:
  assumes "halts M ns" 
  shows "{pre_H_inv M ns} H {post_H_unhalt_inv}"
  using assms h_case by auto

(* TM that produces the contradiction and its code *)

definition
  "tcontra  (tcopy |+| H) |+| dither"
abbreviation
  "code_tcontra  code tcontra"

(* assume tcontra does not halt on its code *)
lemma tcontra_unhalt: 
  assumes "¬ halts tcontra [code tcontra]"
  shows "False"
proof -
  (* invariants *)
  define P1 where "P1  λtp. tp = ([]::cell list, <code_tcontra>)"
  define P2 where "P2  λtp. tp = ([Bk], <(code_tcontra, code_tcontra)>)"
  define P3 where "P3  λtp. k. tp = (Bk  k, <1::nat>)"

(*
  {P1} tcopy {P2}  {P2} H {P3} 
  ----------------------------
     {P1} (tcopy |+| H) {P3}     {P3} dither {P3}
  ------------------------------------------------
                 {P1} tcontra {P3}
  *)

  have H_wf: "tm_wf0 (tcopy |+| H)" by auto

(* {P1} (tcopy |+| H) {P3} *)
  have first: "{P1} (tcopy |+| H) {P3}" 
  proof (cases rule: Hoare_plus_halt)
    case A_halt (* of tcopy *)
    show "{P1} tcopy {P2}" unfolding P1_def P2_def tape_of_nat_def
      by (rule tcopy_correct)
  next
    case B_halt (* of H *)
    show "{P2} H {P3}"
      unfolding P2_def P3_def 
      using H_halt_inv[OF assms]
      by (simp add: tape_of_prod_def tape_of_list_def)
  qed (simp)

(* {P3} dither {P3} *)
  have second: "{P3} dither {P3}" unfolding P3_def 
    by (rule dither_halts)

(* {P1} tcontra {P3} *)
  have "{P1} tcontra {P3}" 
    unfolding tcontra_def
    by (rule Hoare_plus_halt[OF first second H_wf])

  with assms show "False"
    unfolding P1_def P3_def
    unfolding halts_def
    unfolding Hoare_halt_def 
    apply(auto) apply(rename_tac n)
    apply(drule_tac x = n in spec)
    apply(case_tac "steps0 (Suc 0, [], <code tcontra>) tcontra n")
    apply(auto simp add: tape_of_list_def)
    by (metis append_Nil2 replicate_0)
qed

(* asumme tcontra halts on its code *)
lemma tcontra_halt: 
  assumes "halts tcontra [code tcontra]"
  shows "False"
proof - 
  (* invariants *)
  define P1 where "P1  λtp. tp = ([]::cell list, <code_tcontra>)"
  define P2 where "P2  λtp. tp = ([Bk], <(code_tcontra, code_tcontra)>)"
  define Q3 where "Q3  λtp. k. tp = (Bk  k, <0::nat>)"

(*
  {P1} tcopy {P2}  {P2} H {Q3} 
  ----------------------------
     {P1} (tcopy |+| H) {Q3}     {Q3} dither loops
  ------------------------------------------------
               {P1} tcontra loops
  *)

  have H_wf: "tm_wf0 (tcopy |+| H)" by auto

(* {P1} (tcopy |+| H) {Q3} *)
  have first: "{P1} (tcopy |+| H) {Q3}" 
  proof (cases rule: Hoare_plus_halt)
    case A_halt (* of tcopy *)
    show "{P1} tcopy {P2}" unfolding P1_def P2_def tape_of_nat_def
      by (rule tcopy_correct)
  next
    case B_halt (* of H *)
    then show "{P2} H {Q3}"
      unfolding P2_def Q3_def using H_unhalt_inv[OF assms]
      by(simp add: tape_of_prod_def tape_of_list_def)
  qed (simp)

(* {P3} dither loops *)
  have second: "{Q3} dither " unfolding Q3_def 
    by (rule dither_loops)

(* {P1} tcontra loops *)
  have "{P1} tcontra " 
    unfolding tcontra_def
    by (rule Hoare_plus_unhalt[OF first second H_wf])

  with assms show "False"
    unfolding P1_def
    unfolding halts_def
    unfolding Hoare_halt_def Hoare_unhalt_def
    by (auto simp add: tape_of_list_def)
qed


text False› can finally derived.
›

lemma false: "False"
  using tcontra_halt tcontra_unhalt 
  by auto

end

declare replicate_Suc[simp del]

end

Theory Abacus_Mopup

(* Title: thys/Abacus_Mopup.thy
   Author: Jian Xu, Xingyuan Zhang, and Christian Urban
   Modifications: Sebastiaan Joosten
*)

chapter ‹Mopup Turing Machine that deletes all "registers", except one›

theory Abacus_Mopup
  imports Uncomputable
begin

fun mopup_a :: "nat  instr list"
  where
    "mopup_a 0 = []" |
    "mopup_a (Suc n) = mopup_a n @ 
       [(R, 2*n + 3), (W0, 2*n + 2), (R, 2*n + 1), (W1, 2*n + 2)]"

definition mopup_b :: "instr list"
  where
    "mopup_b  [(R, 2), (R, 1), (L, 5), (W0, 3), (R, 4), (W0, 3),
            (R, 2), (W0, 3), (L, 5), (L, 6), (R, 0), (L, 6)]"

fun mopup :: "nat  instr list"
  where 
    "mopup n = mopup_a n @ shift mopup_b (2*n)"

type_synonym mopup_type = "config  nat list  nat  cell list  bool"

fun mopup_stop :: "mopup_type"
  where
    "mopup_stop (s, l, r) lm n ires= 
        ( ln rn. l = Bkln @ Bk # Bk # ires  r = <lm ! n> @ Bkrn)"

fun mopup_bef_erase_a :: "mopup_type"
  where
    "mopup_bef_erase_a (s, l, r) lm n ires= 
         ( ln m rn. l = Bkln @ Bk # Bk # ires  
                  r = Ocm@ Bk # <(drop ((s + 1) div 2) lm)> @ Bkrn)"

fun mopup_bef_erase_b :: "mopup_type"
  where
    "mopup_bef_erase_b (s, l, r) lm n ires = 
      ( ln m rn. l = Bkln @ Bk # Bk # ires  r = Bk # Ocm @ Bk # 
                                      <(drop (s div 2) lm)> @ Bkrn)"

fun mopup_jump_over1 :: "mopup_type"
  where
    "mopup_jump_over1 (s, l, r) lm n ires = 
      ( ln m1 m2 rn. m1 + m2 = Suc (lm ! n)  
        l = Ocm1 @ Bkln @ Bk # Bk # ires  
     (r = Ocm2 @ Bk # <(drop (Suc n) lm)> @ Bkrn  
     (r = Ocm2  (drop (Suc n) lm) = [])))"

fun mopup_aft_erase_a :: "mopup_type"
  where
    "mopup_aft_erase_a (s, l, r) lm n ires = 
      ( lnl lnr rn (ml::nat list) m. 
          m = Suc (lm ! n)  l = Bklnr @ Ocm @ Bklnl @ Bk # Bk # ires  
                                   (r = <ml> @ Bkrn))"

fun mopup_aft_erase_b :: "mopup_type"
  where
    "mopup_aft_erase_b (s, l, r) lm n ires= 
   ( lnl lnr rn (ml::nat list) m. 
      m = Suc (lm ! n)  
      l = Bklnr @ Ocm @ Bklnl @ Bk # Bk # ires  
     (r = Bk # <ml> @ Bkrn 
      r = Bk # Bk # <ml> @ Bkrn))"

fun mopup_aft_erase_c :: "mopup_type"
  where
    "mopup_aft_erase_c (s, l, r) lm n ires = 
 ( lnl lnr rn (ml::nat list) m. 
     m = Suc (lm ! n)  
     l = Bklnr @ Ocm @ Bklnl @ Bk # Bk # ires  
    (r = <ml> @ Bkrn  r = Bk # <ml> @ Bkrn))"

fun mopup_left_moving :: "mopup_type"
  where
    "mopup_left_moving (s, l, r) lm n ires = 
  ( lnl lnr rn m.
     m = Suc (lm ! n)  
   ((l = Bklnr @ Ocm @ Bklnl @ Bk # Bk # ires  r = Bkrn) 
    (l = Oc(m - 1) @ Bklnl @ Bk # Bk # ires  r = Oc # Bkrn)))"

fun mopup_jump_over2 :: "mopup_type"
  where
    "mopup_jump_over2 (s, l, r) lm n ires = 
     ( ln rn m1 m2.
          m1 + m2 = Suc (lm ! n) 
         r  [] 
         (hd r = Oc  (l = Ocm1 @ Bkln @ Bk # Bk # ires  r = Ocm2 @ Bkrn)) 
         (hd r = Bk  (l = Bkln @ Bk # ires  r = Bk # Oc(m1+m2)@ Bkrn)))"


fun mopup_inv :: "mopup_type"
  where
    "mopup_inv (s, l, r) lm n ires = 
      (if s = 0 then mopup_stop (s, l, r) lm n ires
       else if s  2*n then
               if s mod 2 = 1 then mopup_bef_erase_a (s, l, r) lm n ires
                   else mopup_bef_erase_b (s, l, r) lm n ires
            else if s = 2*n + 1 then 
                mopup_jump_over1 (s, l, r) lm n ires
            else if s = 2*n + 2 then mopup_aft_erase_a (s, l, r) lm n ires
            else if s = 2*n + 3 then mopup_aft_erase_b (s, l, r) lm n ires
            else if s = 2*n + 4 then mopup_aft_erase_c (s, l, r) lm n ires
            else if s = 2*n + 5 then mopup_left_moving (s, l, r) lm n ires
            else if s = 2*n + 6 then mopup_jump_over2 (s, l, r) lm n ires
            else False)"

lemma mop_bef_length[simp]: "length (mopup_a n) = 4 * n"
  by(induct n, simp_all)

lemma mopup_a_nth: 
  "q < n; x < 4  mopup_a n ! (4 * q + x) = 
                             mopup_a (Suc q) ! ((4 * q) + x)"
proof(induct n)
  case (Suc n)
  then show ?case 
    by(cases "q < n";cases "q = n", auto simp add: nth_append)
qed auto

lemma fetch_bef_erase_a_o[simp]: 
  "0 < s; s  2 * n; s mod 2 = Suc 0
   (fetch (mopup_a n @ shift mopup_b (2 * n)) s Oc) = (W0, s + 1)"
  apply(subgoal_tac " q. s = 2*q + 1", auto)
   apply(subgoal_tac "length (mopup_a n) = 4*n")
    apply(auto simp: nth_append)
   apply(subgoal_tac "mopup_a n ! (4 * q + 1) = 
                      mopup_a (Suc q) ! ((4 * q) + 1)", 
      simp add: nth_append)
   apply(rule mopup_a_nth, auto)
  apply arith
  done

lemma fetch_bef_erase_a_b[simp]:
  "0 < s; s  2 * n; s mod 2 = Suc 0
     (fetch (mopup_a n @ shift mopup_b (2 * n)) s Bk) = (R, s + 2)"
  apply(subgoal_tac " q. s = 2*q + 1", auto)
   apply(subgoal_tac "length (mopup_a n) = 4*n")
    apply(auto simp: nth_append)
   apply(subgoal_tac "mopup_a n ! (4 * q + 0) = 
                       mopup_a (Suc q) ! ((4 * q + 0))", 
      simp add: nth_append)
   apply(rule mopup_a_nth, auto)
  apply arith
  done

lemma fetch_bef_erase_b_b: 
  assumes "n < length lm" "0 < s" "s  2 * n" "s mod 2 = 0"
  shows "(fetch (mopup_a n @ shift mopup_b (2 * n)) s Bk) = (R, s - 1)"
proof -
  from assms obtain q where q:"s = 2 * q" by auto
  then obtain nat where nat:"q = Suc nat" using assms(2) by (cases q, auto)
  from assms(3) mopup_a_nth[of nat n 2]
  have "mopup_a n ! (4 * nat + 2) = mopup_a (Suc nat) ! ((4 * nat) + 2)"
    unfolding nat q by auto
  thus ?thesis using assms nat q by (auto simp: nth_append)
qed

lemma fetch_jump_over1_o: 
  "fetch (mopup_a n @ shift mopup_b (2 * n)) (Suc (2 * n)) Oc
  = (R, Suc (2 * n))"
  apply(subgoal_tac "length (mopup_a n) = 4 * n")
   apply(auto simp: mopup_b_def nth_append shift.simps)
  done

lemma fetch_jump_over1_b: 
  "fetch (mopup_a n @ shift mopup_b (2 * n)) (Suc (2 * n)) Bk 
 = (R, Suc (Suc (2 * n)))"
  apply(subgoal_tac "length (mopup_a n) = 4 * n")
   apply(auto simp: mopup_b_def nth_append shift.simps)
  done

lemma fetch_aft_erase_a_o: 
  "fetch (mopup_a n @ shift mopup_b (2 * n)) (Suc (Suc (2 * n))) Oc 
 = (W0, Suc (2 * n + 2))"
  apply(subgoal_tac "length (mopup_a n) = 4 * n")
   apply(auto simp: mopup_b_def nth_append shift.simps)
  done

lemma fetch_aft_erase_a_b: 
  "fetch (mopup_a n @ shift mopup_b (2 * n)) (Suc (Suc (2 * n))) Bk
  = (L, Suc (2 * n + 4))"
  apply(subgoal_tac "length (mopup_a n) = 4 * n")
   apply(auto simp: mopup_b_def nth_append shift.simps)
  done

lemma fetch_aft_erase_b_b: 
  "fetch (mopup_a n @ shift mopup_b (2 * n)) (2*n + 3) Bk
  = (R, Suc (2 * n + 3))"
  apply(subgoal_tac "length (mopup_a n) = 4 * n")
   apply(subgoal_tac "2*n + 3 = Suc (2*n + 2)", simp only: fetch.simps)
    apply(auto simp: mopup_b_def nth_append shift.simps)
  done

lemma fetch_aft_erase_c_o: 
  "fetch (mopup_a n @ shift mopup_b (2 * n)) (2 * n + 4) Oc 
 = (W0, Suc (2 * n + 2))"
  apply(subgoal_tac "length (mopup_a n) = 4 * n")
   apply(subgoal_tac "2*n + 4 = Suc (2*n + 3)", simp only: fetch.simps)
    apply(auto simp: mopup_b_def nth_append shift.simps)
  done

lemma fetch_aft_erase_c_b: 
  "fetch (mopup_a n @ shift mopup_b (2 * n)) (2 * n + 4) Bk 
 = (R, Suc (2 * n + 1))"
  apply(subgoal_tac "length (mopup_a n) = 4 * n")
   apply(subgoal_tac "2*n + 4 = Suc (2*n + 3)", simp only: fetch.simps)
    apply(auto simp: mopup_b_def nth_append shift.simps)
  done

lemma fetch_left_moving_o: 
  "(fetch (mopup_a n @ shift mopup_b (2 * n)) (2 * n + 5) Oc) 
 = (L, 2*n + 6)"
  apply(subgoal_tac "length (mopup_a n) = 4 * n")
   apply(subgoal_tac "2*n + 5 = Suc (2*n + 4)", simp only: fetch.simps)
    apply(auto simp: mopup_b_def nth_append shift.simps)
  done

lemma fetch_left_moving_b: 
  "(fetch (mopup_a n @ shift mopup_b (2 * n)) (2 * n + 5) Bk)
  = (L, 2*n + 5)"
  apply(subgoal_tac "length (mopup_a n) = 4 * n")
   apply(subgoal_tac "2*n + 5 = Suc (2*n + 4)", simp only: fetch.simps)
    apply(auto simp: mopup_b_def nth_append shift.simps)
  done

lemma fetch_jump_over2_b:
  "(fetch (mopup_a n @ shift mopup_b (2 * n)) (2 * n + 6) Bk) 
 = (R, 0)"
  apply(subgoal_tac "length (mopup_a n) = 4 * n")
   apply(subgoal_tac "2*n + 6 = Suc (2*n + 5)", simp only: fetch.simps)
    apply(auto simp: mopup_b_def nth_append shift.simps)
  done

lemma fetch_jump_over2_o: 
  "(fetch (mopup_a n @ shift mopup_b (2 * n)) (2 * n + 6) Oc) 
 = (L, 2*n + 6)"
  apply(subgoal_tac "length (mopup_a n) = 4 * n")
   apply(subgoal_tac "2*n + 6 = Suc (2*n + 5)", simp only: fetch.simps)
    apply(auto simp: mopup_b_def nth_append shift.simps)
  done

lemmas mopupfetchs = 
  fetch_bef_erase_a_o fetch_bef_erase_a_b fetch_bef_erase_b_b 
  fetch_jump_over1_o fetch_jump_over1_b fetch_aft_erase_a_o 
  fetch_aft_erase_a_b fetch_aft_erase_b_b fetch_aft_erase_c_o 
  fetch_aft_erase_c_b fetch_left_moving_o fetch_left_moving_b 
  fetch_jump_over2_b fetch_jump_over2_o

declare 
  mopup_jump_over2.simps[simp del] mopup_left_moving.simps[simp del]
  mopup_aft_erase_c.simps[simp del] mopup_aft_erase_b.simps[simp del] 
  mopup_aft_erase_a.simps[simp del] mopup_jump_over1.simps[simp del]
  mopup_bef_erase_a.simps[simp del] mopup_bef_erase_b.simps[simp del]
  mopup_stop.simps[simp del]

lemma mopup_bef_erase_b_Bk_via_a_Oc[simp]: 
  "mopup_bef_erase_a (s, l, Oc # xs) lm n ires  
  mopup_bef_erase_b (Suc s, l, Bk # xs) lm n ires"
  apply(auto simp: mopup_bef_erase_a.simps mopup_bef_erase_b.simps)
  by (metis cell.distinct(1) hd_append list.sel(1) list.sel(3) tl_append2 tl_replicate)

lemma mopup_false1:
  "0 < s; s  2 * n; s mod 2 = Suc 0;  ¬ Suc s  2 * n 
   RR"
  apply(arith)
  done

lemma mopup_bef_erase_a_implies_two[simp]: 
  "n < length lm; 0 < s; s  2 * n; s mod 2 = Suc 0; 
   mopup_bef_erase_a (s, l, Oc # xs) lm n ires; r = Oc # xs
  (Suc s  2 * n  mopup_bef_erase_b (Suc s, l, Bk # xs) lm n ires)  
     (¬ Suc s  2 * n  mopup_jump_over1 (Suc s, l, Bk # xs) lm n ires) "
  apply(auto elim!: mopup_false1)
  done

lemma tape_of_nl_cons: "<m # lm> = (if lm = [] then Oc(Suc m)
                    else Oc(Suc m) @ Bk # <lm>)"
  by(cases lm, simp_all add: tape_of_list_def  tape_of_nat_def split: if_splits)

lemma drop_tape_of_cons: 
  "Suc q < length lm; x = lm ! q  <drop q lm> = Oc # Oc  x @ Bk # <drop (Suc q) lm>"
  using Suc_lessD append_Cons list.simps(2) Cons_nth_drop_Suc replicate_Suc tape_of_nl_cons
  by metis

lemma erase2jumpover1:
  "q < length list; 
             rn. <drop q list>  Oc # Oc  (list ! q) @ Bk # <drop (Suc q) list> @ Bk  rn
        <drop q list> = Oc # Oc  (list ! q)"
  apply(erule_tac x = 0 in allE, simp)
  apply(cases "Suc q < length list")
   apply(erule_tac notE)
   apply(rule_tac drop_tape_of_cons, simp_all)
  apply(subgoal_tac "length list = Suc q", auto)
  apply(subgoal_tac "drop q list = [list ! q]")
   apply(simp add: tape_of_nat_def tape_of_list_def replicate_Suc)
  by (metis append_Nil2 append_eq_conv_conj Cons_nth_drop_Suc lessI)

lemma erase2jumpover2:
  "q < length list; rn. <drop q list> @ Bk # Bk  n 
  Oc # Oc  (list ! q) @ Bk # <drop (Suc q) list> @ Bk  rn
   RR"
  apply(cases "Suc q < length list")
   apply(erule_tac x = "Suc n" in allE, simp)
   apply(erule_tac notE, simp add: replicate_Suc)
   apply(rule_tac drop_tape_of_cons, simp_all)
  apply(subgoal_tac "length list = Suc q", auto)
  apply(erule_tac x = "n" in allE, simp add: tape_of_list_def)
  by (metis append_Nil2 append_eq_conv_conj Cons_nth_drop_Suc lessI replicate_Suc tape_of_list_def tape_of_nl_cons)

lemma mod_ex1: "(a mod 2 = Suc 0) = ( q. a = Suc (2 * q))"
  by arith

declare replicate_Suc[simp]

lemma mopup_bef_erase_a_2_jump_over[simp]:
  "n < length lm; 0 < s; s mod 2 = Suc 0;  s  2 * n;
   mopup_bef_erase_a (s, l, Bk # xs) lm n ires; ¬ (Suc (Suc s)  2 * n) 
 mopup_jump_over1 (s', Bk # l, xs) lm n ires"
proof(cases n)
  case (Suc nat)
  assume assms: "n < length lm" "0 < s" "s mod 2 = Suc 0" "s  2 * n"
    "mopup_bef_erase_a (s, l, Bk # xs) lm n ires" "¬ (Suc (Suc s)  2 * n)"
  from assms obtain a lm' where Cons:"lm = Cons a lm'" by (cases lm,auto)
  from assms have n:"Suc s div 2 = n" by auto
  have [simp]:"s = Suc (2 * q)  q = nat" for q using assms Suc by presburger
  from assms obtain ln m rn where ln:"l = Bk  ln @ Bk # Bk # ires"
    and "Bk # xs = Oc  m @ Bk # <drop (Suc s div 2) lm> @ Bk  rn"
    by (auto simp: mopup_bef_erase_a.simps mopup_jump_over1.simps)
  hence xs:"xs = <drop n lm> @ Bk  rn" by(cases m;auto simp: n mod_ex1)
  have [intro]:"nat < length lm' 
    rna. xs  Oc # Oc  (lm' ! nat) @ Bk # <drop (Suc nat) lm'> @ Bk  rna 
    <drop nat lm'> @ Bk  rn = Oc # Oc  (lm' ! nat)"
    by(cases rn, auto elim: erase2jumpover1 erase2jumpover2 simp:xs Suc Cons)
  have [intro]:"<drop nat lm'>  Oc # Oc  (lm' ! nat) @ Bk # <drop (Suc nat) lm'> @ Bk  0  length lm'  Suc nat"
    using drop_tape_of_cons[of nat lm'] by fastforce
  from assms(1,3) have [intro!]:"
            0 + Suc (lm' ! nat) = Suc (lm' ! nat) 
            Bk # Bk  ln = Oc  0 @ Bk  Suc ln 
            ((rna. xs = Oc  Suc (lm' ! nat) @ Bk # <drop (Suc nat) lm'> @ Bk  rna) 
             xs = Oc  Suc (lm' ! nat)  length lm'  Suc nat)"
    by (auto simp:Cons ln xs Suc)
  from assms(1,3) show ?thesis unfolding Cons ln Suc
    by(auto simp: mopup_bef_erase_a.simps mopup_jump_over1.simps simp del:split_head_repeat)
qed auto


lemma Suc_Suc_div:  "0 < s; s mod 2 = Suc 0; Suc (Suc s)  2 * n
            (Suc (Suc (s div 2)))  n" by(arith)

lemma mopup_bef_erase_a_2_a[simp]: 
  assumes "n < length lm" "0 < s" "s mod 2 = Suc 0" 
    "mopup_bef_erase_a (s, l, Bk # xs) lm n ires"
    "Suc (Suc s)  2 * n"
  shows "mopup_bef_erase_a (Suc (Suc s), Bk # l, xs) lm n ires"
proof-
  from assms obtain rn m ln where
    rn:"l = Bk  ln @ Bk # Bk # ires" "Bk # xs = Oc  m @ Bk # <drop (Suc s div 2) lm> @ Bk  rn"
    by (auto simp: mopup_bef_erase_a.simps)
  hence m:"m = 0" using assms by (cases m,auto)
  hence d:"drop (Suc (Suc (s div 2))) lm  []"
    using assms(1,3,5) by auto arith
  hence "Bk # l = Bk  Suc ln @ Bk # Bk # ires 
    xs = Oc  Suc (lm ! (Suc s div 2)) @ Bk # <drop ((Suc (Suc s) + 1) div 2) lm> @ Bk  rn"
    using rn by(auto intro:drop_tape_of_cons simp:m) 
  thus ?thesis unfolding mopup_bef_erase_a.simps by blast
qed

lemma mopup_false2: 
  "0 < s; s  2 * n; 
   s mod 2 = Suc 0; Suc s  2 * n;
   ¬ Suc (Suc s)  2 * n  RR"
  by(arith)

lemma ariths[simp]: "0 < s; s  2 *n; s mod 2  Suc 0  
                                      (s - Suc 0) mod 2 = Suc 0"
  "0 < s; s  2 *n; s mod 2  Suc 0 
                                       s - Suc 0  2 * n"
  "0 < s; s  2 *n; s mod 2  Suc 0  ¬ s  Suc 0"
  by(arith)+

lemma take_suc[intro]:
  "lna. Bk # Bk  ln = Bk  lna"
  by(rule_tac x = "Suc ln" in exI, simp)


lemma mopup_bef_erase[simp]: "mopup_bef_erase_a (s, l, []) lm n ires  
                        mopup_bef_erase_a (s, l, [Bk]) lm n ires"
  "n < length lm; 0 < s; s  2 * n; s mod 2 = Suc 0; ¬ Suc (Suc s)  2 *n;
     mopup_bef_erase_a (s, l, []) lm n ires
      mopup_jump_over1 (s', Bk # l, []) lm n ires"
  "mopup_bef_erase_b (s, l, Oc # xs) lm n ires  l  []"
  "n < length lm; 0 < s; s  2 * n; 
               s mod 2  Suc 0; 
               mopup_bef_erase_b (s, l, Bk # xs) lm n ires; r = Bk # xs 
            mopup_bef_erase_a (s - Suc 0, Bk # l, xs) lm n ires"
  "mopup_bef_erase_b (s, l, []) lm n ires  
                   mopup_bef_erase_a (s - Suc 0, Bk # l, []) lm n ires"
  by(auto simp: mopup_bef_erase_b.simps mopup_bef_erase_a.simps)


lemma mopup_jump_over1_in_ctx[simp]:
  assumes "mopup_jump_over1 (Suc (2 * n), l, Oc # xs) lm n ires"
  shows "mopup_jump_over1 (Suc (2 * n), Oc # l, xs) lm n ires"
proof -
  from assms obtain ln m1 m2 rn where
    "m1 + m2 = Suc (lm ! n)"
    "l = Oc  m1 @ Bk  ln @ Bk # Bk # ires"
    "(Oc # xs = Oc  m2 @ Bk # <drop (Suc n) lm> @ Bk  rn 
         Oc # xs = Oc  m2  drop (Suc n) lm = [])" unfolding mopup_jump_over1.simps by blast
  thus ?thesis unfolding mopup_jump_over1.simps
    apply(rule_tac x = ln in exI, rule_tac x = "Suc m1" in exI
        ,rule_tac x = "m2 - 1" in exI)
    by(cases "m2", auto)
qed

lemma mopup_jump_over1_2_aft_erase_a[simp]:  
  assumes "mopup_jump_over1 (Suc (2 * n), l, Bk # xs) lm n ires"
  shows "mopup_aft_erase_a (Suc (Suc (2 * n)), Bk # l, xs) lm n ires"
proof -
  from assms obtain ln m1 m2 rn where
    "m1 + m2 = Suc (lm ! n)"
    "l = Oc  m1 @ Bk  ln @ Bk # Bk # ires"
    "(Bk # xs = Oc  m2 @ Bk # <drop (Suc n) lm> @ Bk  rn 
        Bk # xs = Oc  m2  drop (Suc n) lm = [])" unfolding mopup_jump_over1.simps by blast
  thus ?thesis unfolding mopup_aft_erase_a.simps
    apply( rule_tac x = ln in exI, rule_tac x = "Suc 0" in exI,rule_tac x = rn in exI
        , rule_tac x = "drop (Suc n) lm" in exI)
    by(cases m2, auto)
qed

lemma mopup_aft_erase_a_via_jump_over1[simp]: 
  "mopup_jump_over1 (Suc (2 * n), l, []) lm n ires  
    mopup_aft_erase_a (Suc (Suc (2 * n)), Bk # l, []) lm n ires"
proof(rule mopup_jump_over1_2_aft_erase_a)
  assume a:"mopup_jump_over1 (Suc (2 * n), l, []) lm n ires"
  then obtain ln where ln:"length lm  Suc n  l = Oc # Oc  (lm ! n) @ Bk  ln @ Bk # Bk # ires"
    unfolding mopup_jump_over1.simps by auto
  show "mopup_jump_over1 (Suc (2 * n), l, [Bk]) lm n ires"
    unfolding mopup_jump_over1.simps
    apply(rule_tac x = ln in exI, rule_tac x = "Suc (lm ! n)" in exI, 
        rule_tac x = 0 in exI)
    using a ln by(auto simp: mopup_jump_over1.simps tape_of_list_def )
qed

lemma tape_of_list_empty[simp]: "<[]> = []" by(simp add: tape_of_list_def)

lemma mopup_aft_erase_b_via_a[simp]: 
  assumes "mopup_aft_erase_a (Suc (Suc (2 * n)), l, Oc # xs) lm n ires"
  shows "mopup_aft_erase_b (Suc (Suc (Suc (2 * n))), l, Bk # xs) lm n ires"
proof -
  from assms obtain lnl lnr rn ml where
    assms:
    "l = Bk  lnr @ Oc  Suc (lm ! n) @ Bk  lnl @ Bk # Bk # ires"
    "Oc # xs = <ml::nat list> @ Bk  rn"
    unfolding mopup_aft_erase_a.simps by auto
  then obtain a list where ml:"ml = a # list" by (cases ml,cases rn,auto)
  with assms show ?thesis unfolding mopup_aft_erase_b.simps
    apply(auto simp add: tape_of_nl_cons split: if_splits)
     apply(cases a, simp_all)
      apply(rule_tac x = rn in exI, rule_tac x = "[]" in exI, force)
     apply(rule_tac x = rn in exI, rule_tac x = "[a-1]" in exI)
     apply(cases "a"; force simp add: tape_of_list_def tape_of_nat_def) 
    apply(cases "a")
     apply(rule_tac x = rn in exI, rule_tac x = list in exI, force)
    apply(rule_tac x = rn in exI,rule_tac x = "(a-1) # list" in exI, simp add: tape_of_nl_cons)
    done
qed

lemma mopup_left_moving_via_aft_erase_a[simp]:
  assumes "mopup_aft_erase_a (Suc (Suc (2 * n)), l, Bk # xs) lm n ires"
  shows "mopup_left_moving (5 + 2 * n, tl l, hd l # Bk # xs) lm n ires"
proof-
  from assms[unfolded mopup_aft_erase_a.simps] obtain lnl lnr rn ml where
    "l = Bk  lnr @ Oc  Suc (lm ! n) @ Bk  lnl @ Bk # Bk # ires"
    "Bk # xs = <ml::nat list> @ Bk  rn"
    by auto
  thus ?thesis unfolding mopup_left_moving.simps
    by(cases lnr;cases ml,auto simp: tape_of_nl_cons)
qed

lemma mopup_aft_erase_a_nonempty[simp]:
  "mopup_aft_erase_a (Suc (Suc (2 * n)), l, xs) lm n ires  l  []"
  by(auto simp only: mopup_aft_erase_a.simps)

lemma mopup_left_moving_via_aft_erase_a_emptylst[simp]:
  assumes "mopup_aft_erase_a (Suc (Suc (2 * n)), l, []) lm n ires"
  shows "mopup_left_moving (5 + 2 * n, tl l, [hd l]) lm n ires"
proof -
  have [intro!]:"[Bk] = Bk  1" by auto
  from assms obtain lnl lnr where "l = Bk  lnr @ Oc # Oc  (lm ! n) @ Bk  lnl @ Bk # Bk # ires"
    unfolding mopup_aft_erase_a.simps by auto
  thus ?thesis by(case_tac lnr, auto simp add:mopup_left_moving.simps)
qed

lemma mopup_aft_erase_b_no_Oc[simp]: "mopup_aft_erase_b (2 * n + 3, l, Oc # xs) lm n ires = False"
  by(auto simp: mopup_aft_erase_b.simps)

lemma tape_of_ex1[intro]: 
  "rna ml. Oc  a @ Bk  rn = <ml::nat list> @ Bk  rna  Oc  a @ Bk  rn = Bk # <ml> @ Bk  rna"
  by(rule_tac x = rn in exI, rule_tac x = "if a = 0 then [] else [a-1]" in exI,
      simp add: tape_of_list_def tape_of_nat_def)

lemma mopup_aft_erase_b_via_c_helper: "rna ml. Oc  a @ Bk # <list::nat list> @ Bk  rn = 
  <ml> @ Bk  rna  Oc  a @ Bk # <list> @ Bk  rn = Bk # <ml::nat list> @ Bk  rna"
  apply(cases "list = []", simp add: replicate_Suc[THEN sym] del: replicate_Suc split_head_repeat)
   apply(rule_tac rn = "Suc rn" in tape_of_ex1)
  apply(cases a, simp)
   apply(rule_tac x = rn in exI, rule_tac x = list in exI, simp)
  apply(rule_tac x = rn in exI, rule_tac x = "(a-1) # list" in exI)
  apply(simp add: tape_of_nl_cons)
  done

lemma mopup_aft_erase_b_via_c[simp]: 
  assumes "mopup_aft_erase_c (2 * n + 4, l, Oc # xs) lm n ires"
  shows "mopup_aft_erase_b (Suc (Suc (Suc (2 * n))), l, Bk # xs) lm n ires"
proof-
  from assms obtain lnl rn lnr ml where assms:
    "l = Bk  lnr @ Oc # Oc  (lm ! n) @ Bk  lnl @ Bk # Bk # ires"
    "Oc # xs = <ml::nat list> @ Bk  rn" unfolding mopup_aft_erase_c.simps by auto
  hence "Oc # xs = Bk  rn  False" by(cases rn,auto)
  thus ?thesis using assms unfolding mopup_aft_erase_b.simps
    by(cases ml)
      (auto simp add: tape_of_nl_cons split: if_splits intro:mopup_aft_erase_b_via_c_helper
        simp del:split_head_repeat)
qed

lemma mopup_aft_erase_c_aft_erase_a[simp]: 
  assumes "mopup_aft_erase_c (2 * n + 4, l, Bk # xs) lm n ires"
  shows "mopup_aft_erase_a (Suc (Suc (2 * n)), Bk # l, xs) lm n ires"
proof -
  from assms obtain lnl lnr rn ml where
    "l = Bk  lnr @ Oc  Suc (lm ! n) @ Bk  lnl @ Bk # Bk # ires"
    "(Bk # xs = <ml::nat list> @ Bk  rn  Bk # xs = Bk # <ml> @ Bk  rn)"
    unfolding mopup_aft_erase_c.simps by auto
  thus ?thesis unfolding mopup_aft_erase_a.simps
    apply(clarify)
    apply(erule disjE)
     apply(subgoal_tac "ml = []", simp, case_tac rn, 
        simp, simp, rule conjI)
       apply(rule_tac x = lnl in exI, rule_tac x = "Suc lnr" in exI, simp)
      apply (insert tape_of_list_empty,blast)
     apply(case_tac ml, simp, simp add: tape_of_nl_cons split: if_splits)
    apply(rule_tac x = lnl in exI, rule_tac x = "Suc lnr" in exI)
    apply(rule_tac x = rn in exI, rule_tac x = "ml" in exI, simp)
    done
qed

lemma mopup_aft_erase_a_via_c[simp]: 
  "mopup_aft_erase_c (2 * n + 4, l, []) lm n ires 
  mopup_aft_erase_a (Suc (Suc (2 * n)), Bk # l, []) lm n ires"
  by (rule mopup_aft_erase_c_aft_erase_a)
    (auto simp:mopup_aft_erase_c.simps)

lemma mopup_aft_erase_b_2_aft_erase_c[simp]:
  assumes "mopup_aft_erase_b (2 * n + 3, l, Bk # xs) lm n ires"
  shows "mopup_aft_erase_c (4 + 2 * n, Bk # l, xs) lm n ires"
proof -
  from assms obtain lnl lnr ml rn where
    "l = Bk  lnr @ Oc  Suc (lm ! n) @ Bk  lnl @ Bk # Bk # ires"
    "Bk # xs = Bk # <ml::nat list> @ Bk  rn  Bk # xs = Bk # Bk # <ml> @ Bk  rn"
    unfolding  mopup_aft_erase_b.simps by auto
  thus ?thesis unfolding mopup_aft_erase_c.simps
    by (rule_tac x = "lnl" in exI) auto
qed

lemma mopup_aft_erase_c_via_b[simp]: 
  "mopup_aft_erase_b (2 * n + 3, l, []) lm n ires 
  mopup_aft_erase_c (4 + 2 * n, Bk # l, []) lm n ires"
  by(auto simp add: mopup_aft_erase_b.simps intro:mopup_aft_erase_b_2_aft_erase_c)

lemma mopup_left_moving_nonempty[simp]: 
  "mopup_left_moving (2 * n + 5, l, Oc # xs) lm n ires  l  []"
  by(auto simp: mopup_left_moving.simps)

lemma exp_ind: "a(Suc x) = ax @ [a]"
  by(induct x, auto)

lemma mopup_jump_over2_via_left_moving[simp]:  
  "mopup_left_moving (2 * n + 5, l, Oc # xs) lm n ires
   mopup_jump_over2 (2 * n + 6, tl l, hd l # Oc # xs) lm n ires"
  apply(simp only: mopup_left_moving.simps mopup_jump_over2.simps)
  apply(erule_tac exE)+
  apply(erule conjE, erule disjE, erule conjE)
   apply (simp add: Cons_replicate_eq)
  apply(rename_tac Lnl lnr rn m)
  apply(cases "hd l", simp add:  )
   apply(cases "lm ! n", simp)
    apply(rule exI, rule_tac x = "length xs" in exI, 
      rule_tac x = "Suc 0" in exI, rule_tac x = 0 in exI)
    apply(case_tac Lnl, simp,simp,  simp add: exp_ind[THEN sym])
   apply(cases "lm ! n", simp)
   apply(case_tac Lnl, simp, simp)
  apply(rule_tac x = Lnl in exI, rule_tac x = "length xs" in exI, auto)
  apply(cases "lm ! n", simp)
   apply(case_tac Lnl, simp_all add: numeral_2_eq_2)
  done

lemma mopup_left_moving_nonempty_snd[simp]: "mopup_left_moving (2 * n + 5, l, xs) lm n ires  l  []"
  apply(auto simp: mopup_left_moving.simps)
  done

lemma mopup_left_moving_hd_Bk[simp]:
  "mopup_left_moving (2 * n + 5, l, Bk # xs) lm n ires 
  mopup_left_moving (2 * n + 5, tl l, hd l # Bk # xs) lm n ires"
  apply(simp only: mopup_left_moving.simps)
  apply(erule exE)+ apply(rename_tac lnl Lnr rn m)
  apply(case_tac Lnr, auto)
  done

lemma mopup_left_moving_emptylist[simp]: 
  "mopup_left_moving (2 * n + 5, l, []) lm n ires
     mopup_left_moving (2 * n + 5, tl l, [hd l]) lm n ires"
  apply(simp only: mopup_left_moving.simps)
  apply(erule exE)+ apply(rename_tac lnl Lnr rn m)
  apply(case_tac Lnr, auto)
  apply(rule_tac x = 1 in exI, simp)
  done


lemma mopup_jump_over2_Oc_nonempty[simp]: 
  "mopup_jump_over2 (2 * n + 6, l, Oc # xs) lm n ires  l  []"
  apply(auto simp: mopup_jump_over2.simps )
  done

lemma mopup_jump_over2_context[simp]: 
  "mopup_jump_over2 (2 * n + 6, l, Oc # xs) lm n ires
   mopup_jump_over2 (2 * n + 6, tl l, hd l # Oc # xs) lm n ires"
  apply(simp only: mopup_jump_over2.simps)
  apply(erule_tac exE)+
  apply(simp, erule conjE, erule_tac conjE)
  apply(rename_tac Ln Rn M1 M2)
  apply(case_tac M1, simp)
   apply(rule_tac x = Ln in exI, rule_tac x = Rn in exI, 
      rule_tac x = 0 in exI)
   apply(case_tac Ln, simp, simp, simp only: exp_ind[THEN sym], simp)
  apply(rule_tac x = Ln in exI, rule_tac x = Rn in exI, 
      rule_tac x = "M1-1" in exI, rule_tac x = "Suc M2" in exI, simp)
  done

lemma mopup_stop_via_jump_over2[simp]: 
  "mopup_jump_over2 (2 * n + 6, l, Bk # xs) lm n ires 
   mopup_stop (0, Bk # l, xs) lm n ires"
  apply(auto simp: mopup_jump_over2.simps mopup_stop.simps tape_of_nat_def)
  apply(simp add: exp_ind[THEN sym])
  done

lemma mopup_jump_over2_nonempty[simp]: "mopup_jump_over2 (2 * n + 6, l, []) lm n ires = False"
  by(auto simp: mopup_jump_over2.simps)

declare fetch.simps[simp del]
lemma mod_ex2: "(a mod (2::nat) = 0) = ( q. a = 2 * q)"
  by arith

lemma mod_2: "x mod 2  = 0   x mod 2 = Suc 0"
  by arith


lemma mopup_inv_step:
  "n < length lm; mopup_inv (s, l, r) lm n ires
   mopup_inv (step (s, l, r) (mopup_a n @ shift mopup_b (2 * n), 0)) lm n ires"
  apply(cases r;cases "hd r")
     apply(auto split:if_splits simp add:step.simps mopupfetchs fetch.simps(1))
      apply(drule_tac mopup_false2, simp_all add: mopup_bef_erase_b.simps)
    apply(drule_tac mopup_false2, simp_all)
   apply(drule_tac mopup_false2, simp_all)
  by presburger

declare mopup_inv.simps[simp del]
lemma mopup_inv_steps: 
  "n < length lm; mopup_inv (s, l, r) lm n ires  
     mopup_inv (steps (s, l, r) (mopup_a n @ shift mopup_b (2 * n), 0)  stp) lm n ires"
proof(induct stp)
  case (Suc stp)
  then show ?case 
    by ( cases "steps (s, l, r) 
                (mopup_a n @ shift mopup_b (2 * n), 0) stp"
        , auto simp add: steps.simps intro:mopup_inv_step)
qed (auto simp add: steps.simps)

fun abc_mopup_stage1 :: "config  nat  nat"
  where
    "abc_mopup_stage1 (s, l, r) n = 
           (if s > 0  s  2*n then 6
            else if s = 2*n + 1 then 4
            else if s  2*n + 2  s  2*n + 4 then 3
            else if s = 2*n + 5 then 2
            else if s = 2*n + 6 then 1
            else 0)"

fun abc_mopup_stage2 :: "config  nat  nat"
  where
    "abc_mopup_stage2 (s, l, r) n = 
           (if s > 0  s  2*n then length r
            else if s = 2*n + 1 then length r
            else if s = 2*n + 5 then length l
            else if s = 2*n + 6 then length l
            else if s  2*n + 2  s  2*n + 4 then length r
            else 0)"

fun abc_mopup_stage3 :: "config  nat  nat"
  where
    "abc_mopup_stage3 (s, l, r) n = 
          (if s > 0  s  2*n then 
              if hd r = Bk then 0
              else 1
           else if s = 2*n + 2 then 1 
           else if s = 2*n + 3 then 0
           else if s = 2*n + 4 then 2
           else 0)"

definition
  "abc_mopup_measure = measures [λ(c, n). abc_mopup_stage1 c n, 
                                 λ(c, n). abc_mopup_stage2 c n, 
                                 λ(c, n). abc_mopup_stage3 c n]"

lemma wf_abc_mopup_measure:
  shows "wf abc_mopup_measure" 
  unfolding abc_mopup_measure_def 
  by auto

lemma abc_mopup_measure_induct [case_names Step]: 
  "n. ¬ P (f n)  (f (Suc n), (f n))  abc_mopup_measure  n. P (f n)"
  using wf_abc_mopup_measure
  by (metis wf_iff_no_infinite_down_chain)

lemma mopup_erase_nonempty[simp]:
  "mopup_bef_erase_a (a, aa, []) lm n ires = False"
  "mopup_bef_erase_b (a, aa, []) lm n ires = False"
  "mopup_aft_erase_b (2 * n + 3, aa, []) lm n ires = False"
  by(auto simp: mopup_bef_erase_a.simps mopup_bef_erase_b.simps mopup_aft_erase_b.simps)

declare mopup_inv.simps[simp del]

lemma fetch_mopup_a_shift[simp]: 
  assumes "0 < q" "q  n"
  shows "fetch (mopup_a n @ shift mopup_b (2 * n)) (2*q) Bk = (R, 2*q - 1)"
proof(cases q)
  case (Suc nat) with assms
  have "mopup_a n ! (4 * nat + 2) = mopup_a (Suc nat) ! ((4 * nat) + 2)" using assms
    by (metis Suc_le_lessD add_2_eq_Suc' less_Suc_eq mopup_a_nth numeral_Bit0)
  then show ?thesis using assms Suc
    by(auto simp: fetch.simps nth_of.simps nth_append)
qed (insert assms,auto)

lemma mopup_halt:
  assumes 
    less: "n < length lm"
    and inv: "mopup_inv (Suc 0, l, r) lm n ires"
    and f: "f = (λ stp. (steps (Suc 0, l, r) (mopup_a n @ shift mopup_b (2 * n), 0) stp, n))"
    and P: "P = (λ (c, n). is_final c)"
  shows " stp. P (f stp)"
proof (induct rule: abc_mopup_measure_induct) 
  case (Step na)
  have h: "¬ P (f na)" by fact
  show "(f (Suc na), f na)  abc_mopup_measure"
  proof(simp add: f)
    obtain a b c where g:"steps (Suc 0, l, r) (mopup_a n @ shift mopup_b (2 * n), 0) na = (a, b, c)"
      apply(case_tac "steps (Suc 0, l, r) (mopup_a n @ shift mopup_b (2 * n), 0) na", auto)
      done
    then have "mopup_inv (a, b, c) lm n ires"
      using inv less mopup_inv_steps[of n lm "Suc 0" l r ires na]
      apply(simp)
      done
    moreover have "a > 0"
      using h g
      apply(simp add: f P)
      done
    ultimately 
    have "((step (a, b, c) (mopup_a n @ shift mopup_b (2 * n), 0), n), (a, b, c), n)  abc_mopup_measure"
      apply(case_tac c;cases "hd c")
         apply(auto split:if_splits simp add:step.simps mopup_inv.simps mopup_bef_erase_b.simps)
      by (auto split:if_splits simp: mopupfetchs abc_mopup_measure_def )
    thus "((step (steps (Suc 0, l, r) (mopup_a n @ shift mopup_b (2 * n), 0) na) 
      (mopup_a n @ shift mopup_b (2 * n), 0), n),
      steps (Suc 0, l, r) (mopup_a n @ shift mopup_b (2 * n), 0) na, n)
       abc_mopup_measure"
      using g by simp
  qed
qed

lemma mopup_inv_start: 
  "n < length am  mopup_inv (Suc 0, Bk # Bk # ires, <am> @ Bk  k) am n ires"
  apply(cases am;auto simp: mopup_inv.simps mopup_bef_erase_a.simps mopup_jump_over1.simps)
    apply(auto simp: tape_of_nl_cons)
     apply(rule_tac x = "Suc (hd am)" in exI, rule_tac x = k in exI, simp)
    apply(cases k;cases n;force)
   apply(cases n; force)
  by(cases n; force split:if_splits)

lemma mopup_correct:
  assumes less: "n < length (am::nat list)"
    and rs: "am ! n = rs"
  shows " stp i j. (steps (Suc 0, Bk # Bk # ires, <am> @ Bk  k) (mopup_a n @ shift mopup_b (2 * n), 0) stp)
    = (0, Bki @ Bk # Bk # ires, Oc # Oc rs @ Bkj)"
  using less
proof -
  have a: "mopup_inv (Suc 0, Bk # Bk # ires, <am> @ Bk  k) am n ires"
    using less
    apply(simp add: mopup_inv_start)
    done    
  then have " stp. is_final (steps (Suc 0, Bk # Bk # ires, <am> @ Bk  k) (mopup_a n @ shift mopup_b (2 * n), 0) stp)"
    using less mopup_halt[of n am  "Bk # Bk # ires" "<am> @ Bk  k" ires
        "(λstp. (steps (Suc 0, Bk # Bk # ires, <am> @ Bk  k) (mopup_a n @ shift mopup_b (2 * n), 0) stp, n))"
        "(λ(c, n). is_final c)"]
    apply(simp)
    done
  from this obtain stp where b:
    "is_final (steps (Suc 0, Bk # Bk # ires, <am> @ Bk  k) (mopup_a n @ shift mopup_b (2 * n), 0) stp)" ..
  from a b have
    "mopup_inv (steps (Suc 0, Bk # Bk # ires, <am> @ Bk  k) (mopup_a n @ shift mopup_b (2 * n), 0) stp)
    am n ires"
    apply(rule_tac mopup_inv_steps, simp_all add: less)
    done    
  from b and this show "?thesis"
    apply(rule_tac x = stp in exI, simp)
    apply(case_tac "steps (Suc 0, Bk # Bk # ires, <am> @ Bk  k) 
      (mopup_a n @ shift mopup_b (2 * n), 0) stp")
    apply(simp add: mopup_inv.simps mopup_stop.simps rs)
    using rs
    apply(simp add: tape_of_nat_def)
    done
qed

lemma wf_mopup[intro]: "tm_wf (mopup n, 0)"
  by(induct n, auto simp add: shift.simps mopup_b_def tm_wf.simps)

end

Theory Abacus

(* Title: thys/Abacus.thy
   Author: Jian Xu, Xingyuan Zhang, and Christian Urban
   Modifications: Sebastiaan Joosten
*)

chapter ‹Abacus Machines›

theory Abacus
  imports Turing_Hoare Abacus_Mopup
begin

declare replicate_Suc[simp add]

(* Abacus instructions *)

datatype abc_inst =
  Inc nat
  | Dec nat nat
  | Goto nat

type_synonym abc_prog = "abc_inst list"

type_synonym abc_state = nat

text ‹
  The memory of Abacus machine is defined as a list of contents, with 
  every units addressed by index into the list.
›
type_synonym abc_lm = "nat list"

text ‹
  Fetching contents out of memory. Units not represented by list elements are considered
  as having content 0›.
›
fun abc_lm_v :: "abc_lm  nat  nat"
  where 
    "abc_lm_v lm n = (if (n < length lm) then (lm!n) else 0)"         


text ‹
  Set the content of memory unit n› to value v›.
  am› is the Abacus memory before setting.
  If address n› is outside to scope of am›, am› 
  is extended so that n› becomes in scope.
›

fun abc_lm_s :: "abc_lm  nat  nat  abc_lm"
  where
    "abc_lm_s am n v = (if (n < length am) then (am[n:=v]) else 
                           am@ (replicate (n - length am) 0) @ [v])"


text ‹
  The configuration of Abaucs machines consists of its current state and its
  current memory:
›
type_synonym abc_conf = "abc_state × abc_lm"

text ‹
  Fetch instruction out of Abacus program:
›

fun abc_fetch :: "nat  abc_prog  abc_inst option" 
  where
    "abc_fetch s p = (if (s < length p) then Some (p ! s) else None)"

text ‹
  Single step execution of Abacus machine. If no instruction is feteched, 
  configuration does not change.
›
fun abc_step_l :: "abc_conf  abc_inst option  abc_conf"
  where
    "abc_step_l (s, lm) a = (case a of 
               None  (s, lm) |
               Some (Inc n)   (let nv = abc_lm_v lm n in
                       (s + 1, abc_lm_s lm n (nv + 1))) |
               Some (Dec n e)  (let nv = abc_lm_v lm n in
                       if (nv = 0) then (e, abc_lm_s lm n 0) 
                       else (s + 1,  abc_lm_s lm n (nv - 1))) |
               Some (Goto n)  (n, lm) 
               )"

text ‹
  Multi-step execution of Abacus machine.
›
fun abc_steps_l :: "abc_conf  abc_prog  nat  abc_conf"
  where
    "abc_steps_l (s, lm) p 0 = (s, lm)" |
    "abc_steps_l (s, lm) p (Suc n) = 
      abc_steps_l (abc_step_l (s, lm) (abc_fetch s p)) p n"

section ‹
  Compiling Abacus machines into Turing machines
›

subsection ‹
  Compiling functions
›

text findnth n› returns the TM which locates the represention of
  memory cell n› on the tape and changes representation of zero
  on the way.
›

fun findnth :: "nat  instr list"
  where
    "findnth 0 = []" |
    "findnth (Suc n) = (findnth n @ [(W1, 2 * n + 1), 
           (R, 2 * n + 2), (R, 2 * n + 3), (R, 2 * n + 2)])"

text tinc_b› returns the TM which increments the representation 
  of the memory cell under rw-head by one and move the representation 
  of cells afterwards to the right accordingly.
›

definition tinc_b :: "instr list"
  where
    "tinc_b  [(W1, 1), (R, 2), (W1, 3), (R, 2), (W1, 3), (R, 4), 
             (L, 7), (W0, 5), (R, 6), (W0, 5), (W1, 3), (R, 6),
             (L, 8), (L, 7), (R, 9), (L, 7), (R, 10), (W0, 9)]" 

text tinc ss n› returns the TM which simulates the execution of 
  Abacus instruction Inc n›, assuming that TM is located at
  location ss› in the final TM complied from the whole
  Abacus program.
›

fun tinc :: "nat  nat  instr list"
  where
    "tinc ss n = shift (findnth n @ shift tinc_b (2 * n)) (ss - 1)"

text tinc_b› returns the TM which decrements the representation 
  of the memory cell under rw-head by one and move the representation 
  of cells afterwards to the left accordingly.
›

definition tdec_b :: "instr list"
  where
    "tdec_b   [(W1, 1), (R, 2), (L, 14), (R, 3), (L, 4), (R, 3),
              (R, 5), (W0, 4), (R, 6), (W0, 5), (L, 7), (L, 8),
              (L, 11), (W0, 7), (W1, 8), (R, 9), (L, 10), (R, 9),
              (R, 5), (W0, 10), (L, 12), (L, 11), (R, 13), (L, 11),
              (R, 17), (W0, 13), (L, 15), (L, 14), (R, 16), (L, 14),
              (R, 0), (W0, 16)]"


text tdec ss n label› returns the TM which simulates the execution of 
  Abacus instruction Dec n label›, assuming that TM is located at
  location ss› in the final TM complied from the whole
  Abacus program.
›

fun tdec :: "nat  nat  nat  instr list"
  where
    "tdec ss n e = shift (findnth n) (ss - 1) @ adjust (shift (shift tdec_b (2 * n)) (ss - 1)) e"

text tgoto f(label)› returns the TM simulating the execution of Abacus instruction
  Goto label›, where f(label)› is the corresponding location of
  label› in the final TM compiled from the overall Abacus program.
›

fun tgoto :: "nat  instr list"
  where
    "tgoto n = [(Nop, n), (Nop, n)]"

text ‹
  The layout of the final TM compiled from an Abacus program is represented
  as a list of natural numbers, where the list element at index n› represents the 
  starting state of the TM simulating the execution of n›-th instruction
  in the Abacus program.
›

type_synonym layout = "nat list"

text length_of i› is the length of the 
  TM simulating the Abacus instruction i›.
›
fun length_of :: "abc_inst  nat"
  where
    "length_of i = (case i of 
                    Inc n    2 * n + 9 |
                    Dec n e  2 * n + 16 |
                    Goto n   1)"

text layout_of ap› returns the layout of Abacus program ap›.
›
fun layout_of :: "abc_prog  layout"
  where "layout_of ap = map length_of ap"


text start_of layout n› looks out the starting state of n›-th
  TM in the finall TM.
›

fun start_of :: "nat list  nat  nat"
  where
    "start_of ly x = (Suc (sum_list (take x ly))) "

text ci lo ss i› complies Abacus instruction i›
  assuming the TM of i› starts from state ss› 
  within the overal layout lo›.
›

fun ci :: "layout  nat  abc_inst  instr list"
  where
    "ci ly ss (Inc n) = tinc ss n"
  | "ci ly ss (Dec n e) = tdec ss n (start_of ly e)"
  | "ci ly ss (Goto n) = tgoto (start_of ly n)"

text tpairs_of ap› transfroms Abacus program ap› pairing
  every instruction with its starting state.
›

fun tpairs_of :: "abc_prog  (nat × abc_inst) list"
  where "tpairs_of ap = (zip (map (start_of (layout_of ap)) 
                         [0..<(length ap)]) ap)"

text tms_of ap› returns the list of TMs, where every one of them simulates
  the corresponding Abacus intruction in ap›.
›

fun tms_of :: "abc_prog  (instr list) list"
  where "tms_of ap = map (λ (n, tm). ci (layout_of ap) n tm) 
                         (tpairs_of ap)"

text tm_of ap› returns the final TM machine compiled from Abacus program ap›.
›
fun tm_of :: "abc_prog  instr list"
  where "tm_of ap = concat (tms_of ap)"

lemma length_findnth: 
  "length (findnth n) = 4 * n"
  by (induct n, auto)

lemma ci_length : "length (ci ns n ai) div 2 = length_of ai"
  apply(auto simp: ci.simps tinc_b_def tdec_b_def length_findnth
      split: abc_inst.splits simp del: adjust.simps)
  done

subsection ‹Representation of Abacus memory by TM tapes›

text crsp acf tcf› meams the abacus configuration acf›
  is corretly represented by the TM configuration tcf›.
›

fun crsp :: "layout  abc_conf  config  cell list  bool"
  where 
    "crsp ly (as, lm) (s, l, r) inres = 
           (s = start_of ly as  ( x. r = <lm> @ Bkx)  
            l = Bk # Bk # inres)"

declare crsp.simps[simp del]

text ‹
  The type of invarints expressing correspondence between 
  Abacus configuration and TM configuration.
›

type_synonym inc_inv_t = "abc_conf  config  cell list  bool"

declare tms_of.simps[simp del] tm_of.simps[simp del]
  layout_of.simps[simp del] abc_fetch.simps [simp del]  
  tpairs_of.simps[simp del] start_of.simps[simp del]
  ci.simps [simp del] length_of.simps[simp del] 
  layout_of.simps[simp del]

text ‹
  The lemmas in this section lead to the correctness of 
  the compilation of Inc n› instruction.
›

declare abc_step_l.simps[simp del] abc_steps_l.simps[simp del]
lemma start_of_nonzero[simp]: "start_of ly as > 0" "(start_of ly as = 0) = False"
   apply(auto simp: start_of.simps)
  done

lemma abc_steps_l_0: "abc_steps_l ac ap 0 = ac"
  by(cases ac, simp add: abc_steps_l.simps)

lemma abc_step_red: 
  "abc_steps_l (as, am) ap stp = (bs, bm)  
  abc_steps_l (as, am) ap (Suc stp) = abc_step_l (bs, bm) (abc_fetch bs ap) "
proof(induct stp arbitrary: as am bs bm)
  case 0
  thus "?case"
    by(simp add: abc_steps_l.simps abc_steps_l_0)
next
  case (Suc stp as am bs bm)
  have ind: "as am bs bm. abc_steps_l (as, am) ap stp = (bs, bm)  
    abc_steps_l (as, am) ap (Suc stp) = abc_step_l (bs, bm) (abc_fetch bs ap)"
    by fact
  have h:" abc_steps_l (as, am) ap (Suc stp) = (bs, bm)" by fact
  obtain as' am' where g: "abc_step_l (as, am) (abc_fetch as ap) = (as', am')"
    by(cases "abc_step_l (as, am) (abc_fetch as ap)", auto)
  then have "abc_steps_l (as', am') ap (Suc stp) = abc_step_l (bs, bm) (abc_fetch bs ap)"
    using h
    by(intro ind, simp add: abc_steps_l.simps)
  thus "?case"
    using g
    by(simp add: abc_steps_l.simps)
qed

lemma tm_shift_fetch: 
  "fetch A s b = (ac, ns); ns  0 
   fetch (shift A off) s b = (ac, ns + off)"
  apply(cases b;cases s)
     apply(auto simp: fetch.simps shift.simps)
  done

lemma tm_shift_eq_step:
  assumes exec: "step (s, l, r) (A, 0) = (s', l', r')"
    and notfinal: "s'  0"
  shows "step (s + off, l, r) (shift A off, off) = (s' + off, l', r')"
  using assms
  apply(simp add: step.simps)
  apply(cases "fetch A s (read r)", auto)
   apply(drule_tac [!] off = off in tm_shift_fetch, simp_all)
  done

declare step.simps[simp del] steps.simps[simp del] shift.simps[simp del]

lemma tm_shift_eq_steps: 
  assumes exec: "steps (s, l, r) (A, 0) stp = (s', l', r')"
    and notfinal: "s'  0"
  shows "steps (s + off, l, r) (shift A off, off) stp = (s' + off, l', r')"
  using exec notfinal
proof(induct stp arbitrary: s' l' r', simp add: steps.simps)
  fix stp s' l' r'
  assume ind: "s' l' r'. steps (s, l, r) (A, 0) stp = (s', l', r'); s'  0 
      steps (s + off, l, r) (shift A off, off) stp = (s' + off, l', r')"
    and h: " steps (s, l, r) (A, 0) (Suc stp) = (s', l', r')" "s'  0"
  obtain s1 l1 r1 where g: "steps (s, l, r) (A, 0) stp = (s1, l1, r1)" 
    apply(cases "steps (s, l, r) (A, 0) stp") by blast
  moreover then have "s1  0"
    using h
    apply(simp add: step_red)
    apply(cases "0 < s1", auto)
    done
  ultimately have "steps (s + off, l, r) (shift A off, off) stp =
                   (s1 + off, l1, r1)"
    apply(intro ind, simp_all)
    done
  thus "steps (s + off, l, r) (shift A off, off) (Suc stp) = (s' + off, l', r')"
    using h g assms
    apply(simp add: step_red)
    apply(intro tm_shift_eq_step, auto)
    done
qed

lemma startof_ge1[simp]: "Suc 0  start_of ly as"
  apply(simp add: start_of.simps)
  done

lemma start_of_Suc1: "ly = layout_of ap; 
       abc_fetch as ap = Some (Inc n)
        start_of ly (Suc as) = start_of ly as + 2 * n + 9"
  apply(auto simp: start_of.simps layout_of.simps  
      length_of.simps abc_fetch.simps 
      take_Suc_conv_app_nth split: if_splits)
  done

lemma start_of_Suc2:
  "ly = layout_of ap;
  abc_fetch as ap = Some (Dec n e)  
        start_of ly (Suc as) = 
            start_of ly as + 2 * n + 16"
  apply(auto simp: start_of.simps layout_of.simps  
      length_of.simps abc_fetch.simps 
      take_Suc_conv_app_nth split: if_splits)
  done

lemma start_of_Suc3:
  "ly = layout_of ap;
  abc_fetch as ap = Some (Goto n)  
  start_of ly (Suc as) = start_of ly as + 1"
  apply(auto simp: start_of.simps layout_of.simps  
      length_of.simps abc_fetch.simps 
      take_Suc_conv_app_nth split: if_splits)
  done

lemma length_ci_inc: 
  "length (ci ly ss (Inc n)) = 4*n + 18"
  apply(auto simp: ci.simps length_findnth tinc_b_def)
  done

lemma length_ci_dec: 
  "length (ci ly ss (Dec n e)) = 4*n + 32"
  apply(auto simp: ci.simps length_findnth tdec_b_def)
  done

lemma length_ci_goto: 
  "length (ci ly ss (Goto n )) = 2"
  apply(auto simp: ci.simps length_findnth tdec_b_def)
  done

lemma take_Suc_last[elim]: "Suc as  length xs  
            take (Suc as) xs = take as xs @ [xs ! as]"
proof(induct xs arbitrary: as)
  case (Cons a xs)
  then show ?case by ( simp, cases as;simp)
qed simp

lemma concat_suc: "Suc as  length xs  
       concat (take (Suc as) xs) = concat (take as xs) @ xs! as"
  apply(subgoal_tac "take (Suc as) xs = take as xs @ [xs ! as]", simp)
  by auto

lemma concat_drop_suc_iff: 
  "Suc n < length tps  concat (drop (Suc n) tps) = 
           tps ! Suc n @ concat (drop (Suc (Suc n)) tps)"
proof(induct tps arbitrary: n)
  case (Cons a tps)
  then show ?case 
    apply(cases tps, simp, simp)
    apply(cases n, simp, simp)
    done
qed simp

declare append_assoc[simp del]

lemma  tm_append:
  "n < length tps; tp = tps ! n  
   tp1 tp2. concat tps = tp1 @ tp @ tp2  tp1 = 
  concat (take n tps)  tp2 = concat (drop (Suc n) tps)"
  apply(rule_tac x = "concat (take n tps)" in exI)
  apply(rule_tac x = "concat (drop (Suc n) tps)" in exI)
  apply(auto)
proof(induct n)
  case 0
  then show ?case by(cases tps; simp)
next
  case (Suc n)
  then show ?case 
    apply(subgoal_tac "concat (take n tps) @ (tps ! n) = 
               concat (take (Suc n) tps)")
     apply(simp only: append_assoc[THEN sym], simp only: append_assoc)
     apply(subgoal_tac " concat (drop (Suc n) tps) = tps ! Suc n @ 
                  concat (drop (Suc (Suc n)) tps)")
      apply (metis append_take_drop_id concat_append)
     apply(rule concat_drop_suc_iff,force)
    by (simp add: concat_suc)
qed

declare append_assoc[simp]

lemma length_tms_of[simp]: "length (tms_of aprog) = length aprog"
  apply(auto simp: tms_of.simps tpairs_of.simps)
  done

lemma ci_nth: 
  "ly = layout_of aprog; 
  abc_fetch as aprog = Some ins
   ci ly (start_of ly as) ins = tms_of aprog ! as"
  apply(simp add: tms_of.simps tpairs_of.simps 
      abc_fetch.simps del: map_append split: if_splits)
  done

lemma t_split:"
        ly = layout_of aprog;
        abc_fetch as aprog = Some ins
        tp1 tp2. concat (tms_of aprog) = 
            tp1 @ (ci ly (start_of ly as) ins) @ tp2
             tp1 = concat (take as (tms_of aprog))  
              tp2 = concat (drop (Suc as) (tms_of aprog))"
  apply(insert tm_append[of "as" "tms_of aprog" 
        "ci ly (start_of ly as) ins"], simp)
  apply(subgoal_tac "ci ly (start_of ly as) ins = (tms_of aprog) ! as")
   apply(subgoal_tac "length (tms_of aprog) = length aprog")
    apply(simp add: abc_fetch.simps split: if_splits, simp)
  apply(intro ci_nth, auto)
  done

lemma div_apart: "x mod (2::nat) = 0; y mod 2 = 0 
           (x + y) div 2 = x div 2 + y div 2"
  by(auto)

lemma length_layout_of[simp]: "length (layout_of aprog) = length aprog"
  by(auto simp: layout_of.simps)

lemma length_tms_of_elem_even[intro]:  "n < length ap  length (tms_of ap ! n) mod 2 = 0"
  apply(cases "ap ! n")
  by (auto simp: tms_of.simps tpairs_of.simps ci.simps length_findnth tinc_b_def tdec_b_def)

lemma compile_mod2: "length (concat (take n (tms_of ap))) mod 2 = 0"
proof(induct n)
  case 0
  then show ?case by (auto simp add: take_Suc_conv_app_nth)
next
  case (Suc n)
  hence "n < length (tms_of ap)  is_even (length (concat (take (Suc n) (tms_of ap))))"
    unfolding take_Suc_conv_app_nth by fastforce
  with Suc show ?case by(cases "n < length (tms_of ap)", auto)
qed

lemma tpa_states:
  "tp = concat (take as (tms_of ap));
  as  length ap  
  start_of (layout_of ap) as = Suc (length tp div 2)"
proof(induct as arbitrary: tp)
  case 0
  thus "?case"
    by(simp add: start_of.simps)
next
  case (Suc as tp)
  have ind: "tp. tp = concat (take as (tms_of ap)); as  length ap 
    start_of (layout_of ap) as = Suc (length tp div 2)" by fact
  have tp: "tp = concat (take (Suc as) (tms_of ap))" by fact
  have le: "Suc as  length ap" by fact
  have a: "start_of (layout_of ap) as = Suc (length (concat (take as (tms_of ap))) div 2)"
    using le
    by(intro ind, simp_all)
  from a tp le show "?case"
    apply(simp add: start_of.simps take_Suc_conv_app_nth)
    apply(subgoal_tac "length (concat (take as (tms_of ap))) mod 2= 0")
     apply(subgoal_tac " length (tms_of ap ! as) mod 2 = 0")
      apply(simp add: Abacus.div_apart) 
      apply(simp add: layout_of.simps ci_length  tms_of.simps tpairs_of.simps)
     apply(auto  intro: compile_mod2)
    done
qed

declare fetch.simps[simp]
lemma append_append_fetch: 
  "length tp1 mod 2 = 0; length tp mod 2 = 0;
      length tp1 div 2 < a  a  length tp1 div 2 + length tp div 2
    fetch (tp1 @ tp @ tp2) a b = fetch tp (a - length tp1 div 2) b "
  apply(subgoal_tac " x. a = length tp1 div 2 + x", erule exE)
   apply(rename_tac x)
   apply(case_tac x, simp)
   apply(subgoal_tac "length tp1 div 2 + Suc nat = 
             Suc (length tp1 div 2 + nat)")
    apply(simp only: fetch.simps nth_of.simps, auto)
   apply(cases b, simp)
    apply(subgoal_tac "2 * (length tp1 div 2) = length tp1", simp)
     apply(subgoal_tac "2 * nat < length tp", simp add: nth_append, simp)
    apply(subgoal_tac "2 * (length tp1 div 2) = length tp1", simp)
    apply(subgoal_tac "2 * nat < length tp", simp add: nth_append, auto)
   apply(auto simp: nth_append)
  apply(rule_tac x = "a - length tp1 div 2" in exI, simp)
  done

lemma step_eq_fetch':
  assumes layout: "ly = layout_of ap"
    and compile: "tp = tm_of ap"
    and fetch: "abc_fetch as ap = Some ins"
    and range1: "s  start_of ly as"
    and range2: "s < start_of ly (Suc as)"
  shows "fetch tp s b = fetch (ci ly (start_of ly as) ins)
       (Suc s - start_of ly as) b "
proof -
  have "tp1 tp2. concat (tms_of ap) = tp1 @ ci ly (start_of ly as) ins @ tp2 
    tp1 = concat (take as (tms_of ap))  tp2 = concat (drop (Suc as) (tms_of ap))"
    using assms
    by(intro t_split, simp_all)
  then obtain tp1 tp2 where a: "concat (tms_of ap) = tp1 @ ci ly (start_of ly as) ins @ tp2 
    tp1 = concat (take as (tms_of ap))  tp2 = concat (drop (Suc as) (tms_of ap))" by blast
  then have b: "start_of (layout_of ap) as = Suc (length tp1 div 2)"
    using fetch
    by(intro tpa_states, simp, simp add: abc_fetch.simps split: if_splits)
  have "fetch (tp1 @ (ci ly (start_of ly as) ins) @ tp2)  s b = 
        fetch (ci ly (start_of ly as) ins) (s - length tp1 div 2) b"
  proof(intro append_append_fetch)
    show "length tp1 mod 2 = 0"
      using a
      by(auto, rule_tac compile_mod2)
  next
    show "length (ci ly (start_of ly as) ins) mod 2 = 0"
      by(cases ins, auto simp: ci.simps length_findnth tinc_b_def tdec_b_def)
  next
    show "length tp1 div 2 < s  s  
      length tp1 div 2 + length (ci ly (start_of ly as) ins) div 2"
    proof -
      have "length (ci ly (start_of ly as) ins) div 2 = length_of ins"
        using ci_length by simp
      moreover have "start_of ly (Suc as) = start_of ly as + length_of ins"
        using fetch layout
        apply(simp add: start_of.simps abc_fetch.simps List.take_Suc_conv_app_nth 
            split: if_splits)
        apply(simp add: layout_of.simps)
        done
      ultimately show "?thesis"
        using b layout range1 range2
        apply(simp)
        done
    qed
  qed
  thus "?thesis"
    using b layout a compile  
    apply(simp add: tm_of.simps)
    done
qed

lemma step_eq_fetch: 
  assumes layout: "ly = layout_of ap"
    and compile: "tp = tm_of ap"
    and abc_fetch: "abc_fetch as ap = Some ins" 
    and fetch: "fetch (ci ly (start_of ly as) ins)
       (Suc s - start_of ly as) b = (ac, ns)"
    and notfinal: "ns  0"
  shows "fetch tp s b = (ac, ns)"
proof -
  have "s  start_of ly as"
  proof(cases "s  start_of ly as")
    case True thus "?thesis" by simp
  next
    case False 
    have "¬ start_of ly as  s" by fact
    then have "Suc s - start_of ly as = 0"
      by arith
    then have "fetch (ci ly (start_of ly as) ins)
       (Suc s - start_of ly as) b = (Nop, 0)"
      by(simp add: fetch.simps)
    with notfinal fetch show "?thesis"
      by(simp)
  qed
  moreover have "s < start_of ly (Suc as)"
  proof(cases "s < start_of ly (Suc as)")
    case True thus "?thesis" by simp
  next
    case False
    have h: "¬ s < start_of ly (Suc as)"
      by fact
    then have "s > start_of ly as"
      using abc_fetch layout
      apply(simp add: start_of.simps abc_fetch.simps split: if_splits)
      apply(simp add: List.take_Suc_conv_app_nth, auto)
      apply(subgoal_tac "layout_of ap ! as > 0") 
       apply arith
      apply(simp add: layout_of.simps)
      apply(cases "ap!as", auto simp: length_of.simps)
      done
    from this and h have "fetch (ci ly (start_of ly as) ins) (Suc s - start_of ly as) b = (Nop, 0)"
      using abc_fetch layout
      apply(cases b;cases ins)
           apply(simp_all add:Suc_diff_le start_of_Suc2 start_of_Suc1 start_of_Suc3)
      by (simp_all only: length_ci_inc length_ci_dec length_ci_goto, auto)
    from fetch and notfinal this show "?thesis"by simp
  qed
  ultimately show "?thesis"
    using assms
    by(drule_tac b= b and ins = ins in step_eq_fetch', auto)
qed


lemma step_eq_in:
  assumes layout: "ly = layout_of ap"
    and compile: "tp = tm_of ap"
    and fetch: "abc_fetch as ap = Some ins"    
    and exec: "step (s, l, r) (ci ly (start_of ly as) ins, start_of ly as - 1) 
  = (s', l', r')"
    and notfinal: "s'  0"
  shows "step (s, l, r) (tp, 0) = (s', l', r')"
  using assms
  apply(simp add: step.simps)
  apply(cases "fetch (ci (layout_of ap) (start_of (layout_of ap) as) ins)
    (Suc s - start_of (layout_of ap) as) (read r)", simp)
  using layout
  apply(drule_tac s = s and b = "read r" and ac = a in step_eq_fetch, auto)
  done

lemma steps_eq_in:
  assumes layout: "ly = layout_of ap"
    and compile: "tp = tm_of ap"
    and crsp: "crsp ly (as, lm) (s, l, r) ires"
    and fetch: "abc_fetch as ap = Some ins"    
    and exec: "steps (s, l, r) (ci ly (start_of ly as) ins, start_of ly as - 1) stp 
  = (s', l', r')"
    and notfinal: "s'  0"
  shows "steps (s, l, r) (tp, 0) stp = (s', l', r')"
  using exec notfinal
proof(induct stp arbitrary: s' l' r', simp add: steps.simps)
  fix stp s' l' r'
  assume ind: 
    "s' l' r'. steps (s, l, r) (ci ly (start_of ly as) ins, start_of ly as - 1) stp = (s', l', r'); s'  0
               steps (s, l, r) (tp, 0) stp = (s', l', r')"
    and h: "steps (s, l, r) (ci ly (start_of ly as) ins, start_of ly as - 1) (Suc stp) = (s', l', r')" "s'  0"
  obtain s1 l1 r1 where g: "steps (s, l, r) (ci ly (start_of ly as) ins, start_of ly as - 1) stp = 
                        (s1, l1, r1)"
    apply(cases "steps (s, l, r) (ci ly (start_of ly as) ins, start_of ly as - 1) stp") by blast
  moreover hence "s1  0"
    using h
    apply(simp add: step_red)
    apply(cases "0 < s1", simp_all)
    done
  ultimately have "steps (s, l, r) (tp, 0) stp = (s1, l1, r1)"
    apply(rule_tac ind, auto)
    done
  thus "steps (s, l, r) (tp, 0) (Suc stp) = (s', l', r')"
    using h g assms
    apply(simp add: step_red)
    apply(rule_tac step_eq_in, auto)
    done
qed

lemma tm_append_fetch_first: 
  "fetch A s b = (ac, ns); ns  0  
    fetch (A @ B) s b = (ac, ns)"
  by(cases b;cases s;force simp: fetch.simps nth_append split: if_splits)

lemma tm_append_first_step_eq: 
  assumes "step (s, l, r) (A, off) = (s', l', r')"
    and "s'  0"
  shows "step (s, l, r) (A @ B, off) = (s', l', r')"
  using assms
  apply(simp add: step.simps)
  apply(cases "fetch A (s - off) (read r)")
  apply(frule_tac  B = B and b = "read r" in tm_append_fetch_first, auto)
  done

lemma tm_append_first_steps_eq: 
  assumes "steps (s, l, r) (A, off) stp = (s', l', r')"
    and "s'  0"
  shows "steps (s, l, r) (A @ B, off) stp = (s', l', r')"
  using assms
proof(induct stp arbitrary: s' l' r', simp add: steps.simps)
  fix stp s' l' r'
  assume ind: "s' l' r'. steps (s, l, r) (A, off) stp = (s', l', r'); s'  0
     steps (s, l, r) (A @ B, off) stp = (s', l', r')"
    and h: "steps (s, l, r) (A, off) (Suc stp) = (s', l', r')" "s'  0"
  obtain sa la ra where a: "steps (s, l, r) (A, off) stp = (sa, la, ra)"
    apply(cases "steps (s, l, r) (A, off) stp") by blast
  hence "steps (s, l, r) (A @ B, off) stp = (sa, la, ra)  sa  0"
    using h ind[of sa la ra]
    apply(cases sa, simp_all)
    done
  thus "steps (s, l, r) (A @ B, off) (Suc stp) = (s', l', r')"
    using h a
    apply(simp add: step_red)
    apply(intro tm_append_first_step_eq, simp_all)
    done
qed

lemma tm_append_second_fetch_eq:
  assumes
    even: "length A mod 2 = 0"
    and off: "off = length A div 2"
    and fetch: "fetch B s b = (ac, ns)"
    and notfinal: "ns  0"
  shows "fetch (A @ shift B off) (s + off) b = (ac, ns + off)"
  using assms
  by(cases b;cases s,auto simp: nth_append shift.simps split: if_splits)

lemma tm_append_second_step_eq: 
  assumes 
    exec: "step0 (s, l, r) B = (s', l', r')"
    and notfinal: "s'  0"
    and off: "off = length A div 2"
    and even: "length A mod 2 = 0"
  shows "step0 (s + off, l, r) (A @ shift B off) = (s' + off, l', r')"
  using assms
  apply(simp add: step.simps)
  apply(cases "fetch B s (read r)")
  apply(frule_tac tm_append_second_fetch_eq, simp_all, auto)
  done


lemma tm_append_second_steps_eq: 
  assumes 
    exec: "steps (s, l, r) (B, 0) stp = (s', l', r')"
    and notfinal: "s'  0"
    and off: "off = length A div 2"
    and even: "length A mod 2 = 0"
  shows "steps (s + off, l, r) (A @ shift B off, 0) stp = (s' + off, l', r')"
  using exec notfinal
proof(induct stp arbitrary: s' l' r')
  case 0
  thus "steps0 (s + off, l, r) (A @ shift B off) 0 = (s' + off, l', r')"
    by(simp add: steps.simps)
next
  case (Suc stp s' l' r')
  have ind: "s' l' r'. steps0 (s, l, r) B stp = (s', l', r'); s'  0  
    steps0 (s + off, l, r) (A @ shift B off) stp = (s' + off, l', r')"
    by fact
  have h: "steps0 (s, l, r) B (Suc stp) = (s', l', r')" by fact
  have k: "s'  0" by fact
  obtain s'' l'' r'' where a: "steps0 (s, l, r) B stp = (s'', l'', r'')"
    by (metis prod_cases3)
  then have b: "s''  0"
    using h k
    by(intro notI, auto)
  from a b have c: "steps0 (s + off, l, r) (A @ shift B off) stp = (s'' + off, l'', r'')"
    by(erule_tac ind, simp)
  from c b h a k assms show "?case"
    by(auto intro:tm_append_second_step_eq)
qed

lemma tm_append_second_fetch0_eq:
  assumes
    even: "length A mod 2 = 0"
    and off: "off = length A div 2"
    and fetch: "fetch B s b = (ac, 0)"
    and notfinal: "s  0"
  shows "fetch (A @ shift B off) (s + off) b = (ac, 0)"
  using assms
  apply(cases b;cases s)
     apply(auto simp: fetch.simps nth_append shift.simps split: if_splits)
  done

lemma tm_append_second_halt_eq:
  assumes 
    exec: "steps (Suc 0, l, r) (B, 0) stp = (0, l', r')"
    and wf_B: "tm_wf (B, 0)"
    and off: "off = length A div 2"
    and even: "length A mod 2 = 0"
  shows "steps (Suc off, l, r) (A @ shift B off, 0) stp = (0, l', r')"
proof -
  have "n. ¬ is_final (steps0 (1, l, r) B n)  steps0 (1, l, r) B (Suc n) = (0, l', r')"
    using exec by(rule_tac before_final, simp)
  then obtain n where a: 
    "¬ is_final (steps0 (1, l, r) B n)  steps0 (1, l, r) B (Suc n) = (0, l', r')" ..
  obtain s'' l'' r'' where b: "steps0 (1, l, r) B n = (s'', l'', r'')  s'' >0"
    using a
    by(cases "steps0 (1, l, r) B n", auto)
  have c: "steps (Suc 0 + off, l, r) (A @ shift B off, 0) n = (s'' + off, l'', r'')"
    using a b assms
    by(rule_tac tm_append_second_steps_eq, simp_all)
  obtain ac where d: "fetch B s'' (read r'') = (ac, 0)"
    using  b a
    by(cases "fetch B s'' (read r'')", auto simp: step_red step.simps)
  then have "fetch (A @ shift B off) (s'' + off) (read r'') = (ac, 0)"
    using assms b
    by(rule_tac tm_append_second_fetch0_eq, simp_all)
  then have e: "steps (Suc 0 + off, l, r) (A @ shift B off, 0) (Suc n) = (0, l', r')"
    using a b assms c d
    by(simp add: step_red step.simps)
  from a have "n < stp"
    using exec
  proof(cases "n < stp")
    case  True thus "?thesis" by simp
  next
    case False
    have "¬ n < stp" by fact
    then obtain d where  "n = stp + d"
      by (metis add.comm_neutral less_imp_add_positive nat_neq_iff)
    thus "?thesis"
      using a e exec
      by(simp)
  qed
  then obtain d where "stp = Suc n + d"
    by(metis add_Suc less_iff_Suc_add)
  thus "?thesis"
    using e
    by(simp only: steps_add, simp)
qed

lemma tm_append_steps: 
  assumes 
    aexec: "steps (s, l, r) (A, 0) stpa = (Suc (length A div 2), la, ra)"
    and bexec: "steps (Suc 0, la, ra) (B, 0) stpb =  (sb, lb, rb)"
    and notfinal: "sb  0"
    and off: "off = length A div 2"
    and even: "length A mod 2 = 0"
  shows "steps (s, l, r) (A @ shift B off, 0) (stpa + stpb) = (sb + off, lb, rb)"
proof -
  have "steps (s, l, r) (A@shift B off, 0) stpa = (Suc (length A div 2), la, ra)"
    apply(intro tm_append_first_steps_eq)
     apply(auto simp: assms)
    done
  moreover have "steps (1 + off, la, ra) (A @ shift B off, 0) stpb = (sb + off, lb, rb)"
    apply(intro tm_append_second_steps_eq)
       apply(auto simp: assms bexec)
    done
  ultimately show "steps (s, l, r) (A @ shift B off, 0) (stpa + stpb) = (sb + off, lb, rb)"
    apply(simp add: steps_add off)
    done
qed

subsection ‹Crsp of Inc›

fun at_begin_fst_bwtn :: "inc_inv_t"
  where
    "at_begin_fst_bwtn (as, lm) (s, l, r) ires = 
      ( lm1 tn rn. lm1 = (lm @ 0tn)  length lm1 = s  
          (if lm1 = [] then l = Bk # Bk # ires
           else l = [Bk]@<rev lm1>@Bk#Bk#ires)  r = Bkrn)" 


fun at_begin_fst_awtn :: "inc_inv_t"
  where
    "at_begin_fst_awtn (as, lm) (s, l, r) ires = 
      ( lm1 tn rn. lm1 = (lm @ 0tn)  length lm1 = s 
         (if lm1 = []  then l = Bk # Bk # ires
          else l = [Bk]@<rev lm1>@Bk#Bk#ires)  r = [Oc]@Bkrn)"

fun at_begin_norm :: "inc_inv_t"
  where
    "at_begin_norm (as, lm) (s, l, r) ires= 
      ( lm1 lm2 rn. lm = lm1 @ lm2  length lm1 = s  
        (if lm1 = [] then l = Bk # Bk # ires
         else l = Bk # <rev lm1> @ Bk # Bk # ires )  r = <lm2>@Bkrn)"

fun in_middle :: "inc_inv_t"
  where
    "in_middle (as, lm) (s, l, r) ires = 
      ( lm1 lm2 tn m ml mr rn. lm @ 0tn = lm1 @ [m] @ lm2
        length lm1 = s  m + 1 = ml + mr   
         ml  0  tn = s + 1 - length lm  
       (if lm1 = [] then l = Ocml @ Bk # Bk # ires 
        else l = Ocml@[Bk]@<rev lm1>@
                 Bk # Bk # ires)  (r = Ocmr @ [Bk] @ <lm2>@ Bkrn  
      (lm2 = []  r = Ocmr))
      )"

fun inv_locate_a :: "inc_inv_t"
  where "inv_locate_a (as, lm) (s, l, r) ires = 
     (at_begin_norm (as, lm) (s, l, r) ires 
      at_begin_fst_bwtn (as, lm) (s, l, r) ires 
      at_begin_fst_awtn (as, lm) (s, l, r) ires
      )"

fun inv_locate_b :: "inc_inv_t"
  where "inv_locate_b (as, lm) (s, l, r) ires = 
        (in_middle (as, lm) (s, l, r)) ires "

fun inv_after_write :: "inc_inv_t"
  where "inv_after_write (as, lm) (s, l, r) ires = 
           ( rn m lm1 lm2. lm = lm1 @ m # lm2 
             (if lm1 = [] then l = Ocm @ Bk # Bk # ires
              else Oc # l = OcSuc m@ Bk # <rev lm1> @ 
                      Bk # Bk # ires)  r = [Oc] @ <lm2> @ Bkrn)"

fun inv_after_move :: "inc_inv_t"
  where "inv_after_move (as, lm) (s, l, r) ires = 
      ( rn m lm1 lm2. lm = lm1 @ m # lm2 
        (if lm1 = [] then l = OcSuc m @ Bk # Bk # ires
         else l = OcSuc m@ Bk # <rev lm1> @ Bk # Bk # ires)  
        r = <lm2> @ Bkrn)"

fun inv_after_clear :: "inc_inv_t"
  where "inv_after_clear (as, lm) (s, l, r) ires =
       ( rn m lm1 lm2 r'. lm = lm1 @ m # lm2  
        (if lm1 = [] then l = OcSuc m @ Bk # Bk # ires
         else l = OcSuc m @ Bk # <rev lm1> @ Bk # Bk # ires)  
          r = Bk # r'  Oc # r' = <lm2> @ Bkrn)"

fun inv_on_right_moving :: "inc_inv_t"
  where "inv_on_right_moving (as, lm) (s, l, r) ires = 
       ( lm1 lm2 m ml mr rn. lm = lm1 @ [m] @ lm2  
            ml + mr = m  
          (if lm1 = [] then l = Ocml @ Bk # Bk # ires
          else l = Ocml  @ [Bk] @ <rev lm1> @ Bk # Bk # ires)  
         ((r = Ocmr @ [Bk] @ <lm2> @ Bkrn)  
          (r = Ocmr  lm2 = [])))"

fun inv_on_left_moving_norm :: "inc_inv_t"
  where "inv_on_left_moving_norm (as, lm) (s, l, r) ires =
      ( lm1 lm2 m ml mr rn. lm = lm1 @ [m] @ lm2   
             ml + mr = Suc m  mr > 0  (if lm1 = [] then l = Ocml @ Bk # Bk # ires
                                         else l =  Ocml @ Bk # <rev lm1> @ Bk # Bk # ires)
         (r = Ocmr @ Bk # <lm2> @ Bkrn  
           (lm2 = []  r = Ocmr)))"

fun inv_on_left_moving_in_middle_B:: "inc_inv_t"
  where "inv_on_left_moving_in_middle_B (as, lm) (s, l, r) ires =
                ( lm1 lm2 rn. lm = lm1 @ lm2   
                     (if lm1 = [] then l = Bk # ires
                      else l = <rev lm1> @ Bk # Bk # ires)  
                      r = Bk # <lm2> @ Bkrn)"

fun inv_on_left_moving :: "inc_inv_t"
  where "inv_on_left_moving (as, lm) (s, l, r) ires = 
       (inv_on_left_moving_norm  (as, lm) (s, l, r) ires 
        inv_on_left_moving_in_middle_B (as, lm) (s, l, r) ires)"


fun inv_check_left_moving_on_leftmost :: "inc_inv_t"
  where "inv_check_left_moving_on_leftmost (as, lm) (s, l, r) ires = 
                ( rn. l = ires  r = [Bk, Bk] @ <lm> @  Bkrn)"

fun inv_check_left_moving_in_middle :: "inc_inv_t"
  where "inv_check_left_moving_in_middle (as, lm) (s, l, r) ires = 
              ( lm1 lm2 r' rn. lm = lm1 @ lm2 
                 (Oc # l = <rev lm1> @ Bk # Bk # ires)  r = Oc # Bk # r'  
                           r' = <lm2> @  Bkrn)"

fun inv_check_left_moving :: "inc_inv_t"
  where "inv_check_left_moving (as, lm) (s, l, r) ires = 
             (inv_check_left_moving_on_leftmost (as, lm) (s, l, r) ires 
             inv_check_left_moving_in_middle (as, lm) (s, l, r) ires)"

fun inv_after_left_moving :: "inc_inv_t"
  where "inv_after_left_moving (as, lm) (s, l, r) ires= 
              ( rn. l = Bk # ires  r = Bk # <lm> @  Bkrn)"

fun inv_stop :: "inc_inv_t"
  where "inv_stop (as, lm) (s, l, r) ires= 
              ( rn. l = Bk # Bk # ires  r = <lm> @  Bkrn)"

lemma halt_lemma2': 
  "wf LE;   n. ((¬ P (f n)  Q (f n))  
    (Q (f (Suc n))  (f (Suc n), (f n))  LE)); Q (f 0) 
        n. P (f n)"
  apply(intro exCI, simp)
  apply(subgoal_tac " n. Q (f n)")
   apply(drule_tac f = f in wf_inv_image)
   apply(erule wf_induct)
   apply(auto)
  apply(rename_tac n,induct_tac n; simp)
  done

lemma halt_lemma2'': 
  "P (f n); ¬ P (f (0::nat))  
          n. (P (f n)  ( i < n. ¬ P (f i)))"
  apply(induct n rule: nat_less_induct, auto)
  done

lemma halt_lemma2''':
  "n. ¬ P (f n)  Q (f n)  Q (f (Suc n))  (f (Suc n), f n)  LE;
                 Q (f 0);  i<na. ¬ P (f i)  Q (f na)"
  apply(induct na, simp, simp)
  done

lemma halt_lemma2: 
  "wf LE;  
    Q (f 0); ¬ P (f 0);
     n. ((¬ P (f n)  Q (f n))  (Q (f (Suc n))  (f (Suc n), (f n))  LE)) 
    n. P (f n)  Q (f n)"
  apply(insert halt_lemma2' [of LE P f Q], simp, erule_tac exE)
  apply(subgoal_tac " n. (P (f n)  ( i < n. ¬ P (f i)))")
   apply(erule_tac exE)+
   apply(rename_tac n na)
   apply(rule_tac x = na in exI, auto)
   apply(rule halt_lemma2''', simp, simp, simp)
  apply(erule_tac halt_lemma2'', simp)
  done


fun findnth_inv :: "layout  nat  inc_inv_t"
  where
    "findnth_inv ly n (as, lm) (s, l, r) ires =
              (if s = 0 then False
               else if s  Suc (2*n) then 
                  if s mod 2 = 1 then inv_locate_a (as, lm) ((s - 1) div 2, l, r) ires
                  else inv_locate_b (as, lm) ((s - 1) div 2, l, r) ires
               else False)"


fun findnth_state :: "config  nat  nat"
  where
    "findnth_state (s, l, r) n = (Suc (2*n) - s)"

fun findnth_step :: "config  nat  nat"
  where
    "findnth_step (s, l, r) n = 
           (if s mod 2 = 1 then
                   (if (r  []  hd r = Oc) then 0
                    else 1)
            else length r)"

fun findnth_measure :: "config × nat  nat × nat"
  where
    "findnth_measure (c, n) = 
     (findnth_state c n, findnth_step c n)"

definition lex_pair :: "((nat × nat) × nat × nat) set"
  where
    "lex_pair  less_than <*lex*> less_than"

definition findnth_LE :: "((config × nat) × (config × nat)) set"
  where
    "findnth_LE  (inv_image lex_pair findnth_measure)"

lemma wf_findnth_LE: "wf findnth_LE"
  by(auto simp: findnth_LE_def lex_pair_def)

declare findnth_inv.simps[simp del]

lemma x_is_2n_arith[simp]: 
  "x < Suc (Suc (2 * n)); Suc x mod 2 = Suc 0; ¬ x < 2 * n
  x = 2*n"
  by arith


lemma between_sucs:"x < Suc n  ¬ x < n  x = n" by auto

lemma fetch_findnth[simp]: 
  "0 < a; a < Suc (2 * n); a mod 2 = Suc 0  fetch (findnth n) a Oc = (R, Suc a)"
  "0 < a; a < Suc (2 * n); a mod 2  Suc 0  fetch (findnth n) a Oc = (R, a)"
  "0 < a; a < Suc (2 * n); a mod 2  Suc 0  fetch (findnth n) a Bk = (R, Suc a)"
  "0 < a; a < Suc (2 * n); a mod 2 = Suc 0  fetch (findnth n) a Bk = (W1, a)"
  by(cases a;induct n;force simp: length_findnth nth_append dest!:between_sucs)+

declare at_begin_norm.simps[simp del] at_begin_fst_bwtn.simps[simp del] 
  at_begin_fst_awtn.simps[simp del] in_middle.simps[simp del] 
  abc_lm_s.simps[simp del] abc_lm_v.simps[simp del]  
  ci.simps[simp del] inv_after_move.simps[simp del] 
  inv_on_left_moving_norm.simps[simp del] 
  inv_on_left_moving_in_middle_B.simps[simp del]
  inv_after_clear.simps[simp del] 
  inv_after_write.simps[simp del] inv_on_left_moving.simps[simp del]
  inv_on_right_moving.simps[simp del] 
  inv_check_left_moving.simps[simp del] 
  inv_check_left_moving_in_middle.simps[simp del]
  inv_check_left_moving_on_leftmost.simps[simp del] 
  inv_after_left_moving.simps[simp del]
  inv_stop.simps[simp del] inv_locate_a.simps[simp del] 
  inv_locate_b.simps[simp del]

lemma replicate_once[intro]: "rn. [Bk] = Bk  rn"
  by (metis replicate.simps)

lemma at_begin_norm_Bk[intro]:  "at_begin_norm (as, am) (q, aaa, []) ires
              at_begin_norm (as, am) (q, aaa, [Bk]) ires"
  apply(simp add: at_begin_norm.simps)
  by fastforce

lemma at_begin_fst_bwtn_Bk[intro]: "at_begin_fst_bwtn (as, am) (q, aaa, []) ires 
             at_begin_fst_bwtn (as, am) (q, aaa, [Bk]) ires"
  apply(simp only: at_begin_fst_bwtn.simps)
  using replicate_once by blast

lemma at_begin_fst_awtn_Bk[intro]: "at_begin_fst_awtn (as, am) (q, aaa, []) ires
            at_begin_fst_awtn (as, am) (q, aaa, [Bk]) ires"
  apply(auto simp: at_begin_fst_awtn.simps)
  done 

lemma inv_locate_a_Bk[intro]: "inv_locate_a (as, am) (q, aaa, []) ires
             inv_locate_a (as, am) (q, aaa, [Bk]) ires"
  apply(simp only: inv_locate_a.simps)
  apply(erule disj_forward)
   defer
   apply(erule disj_forward, auto)
  done

lemma locate_a_2_locate_a[simp]: "inv_locate_a (as, am) (q, aaa, Bk # xs) ires
        inv_locate_a (as, am) (q, aaa, Oc # xs) ires"
  apply(simp only: inv_locate_a.simps at_begin_norm.simps 
      at_begin_fst_bwtn.simps at_begin_fst_awtn.simps)
  apply(erule_tac disjE, erule exE, erule exE, erule exE, 
      rule disjI2, rule disjI2)
   defer
   apply(erule_tac disjE, erule exE, erule exE, 
      erule exE, rule disjI2, rule disjI2)
    prefer 2
    apply(simp)
proof-
  fix lm1 tn rn
  assume k: "lm1 = am @ 0tn  length lm1 = q  (if lm1 = [] then aaa = Bk # Bk # 
    ires else aaa = [Bk] @ <rev lm1> @ Bk # Bk # ires)  Bk # xs = Bkrn"
  thus "lm1 tn rn. lm1 = am @ 0  tn  length lm1 = q  
    (if lm1 = [] then aaa = Bk # Bk # ires else aaa = [Bk] @ <rev lm1> @ Bk # Bk # ires)  Oc # xs = [Oc] @ Bk  rn"
    (is "lm1 tn rn. ?P lm1 tn rn")
  proof -
    from k have "?P lm1 tn (rn - 1)"
      by (auto simp: Cons_replicate_eq)
    thus ?thesis by blast
  qed
next
  fix lm1 lm2 rn
  assume h1: "am = lm1 @ lm2  length lm1 = q  (if lm1 = [] 
    then aaa = Bk # Bk # ires else aaa = Bk # <rev lm1> @ Bk # Bk # ires) 
    Bk # xs = <lm2> @ Bkrn"
  from h1 have h2: "lm2 = []"
    apply(auto split: if_splits;cases lm2;simp add: tape_of_nl_cons split: if_splits)
    done
  from h1 and h2 show "lm1 tn rn. lm1 = am @ 0tn  length lm1 = q  
    (if lm1 = [] then aaa = Bk # Bk # ires else aaa = [Bk] @ <rev lm1> @ Bk # Bk # ires) 
    Oc # xs = [Oc] @ Bkrn" 
    (is "lm1 tn rn. ?P lm1 tn rn")
  proof -
    from h1 and h2  have "?P lm1 0 (rn - 1)"
      apply(auto simp:tape_of_nat_def)
      by(cases rn, simp, simp)
    thus ?thesis by blast
  qed
qed

lemma inv_locate_a[simp]: "inv_locate_a (as, am) (q, aaa, []) ires  
               inv_locate_a (as, am) (q, aaa, [Oc]) ires"
  apply(insert locate_a_2_locate_a [of as am q aaa "[]"])
  apply(subgoal_tac "inv_locate_a (as, am) (q, aaa, [Bk]) ires", auto)
  done

(*inv: from locate_b to locate_b*)
lemma inv_locate_b[simp]: "inv_locate_b (as, am) (q, aaa, Oc # xs) ires
          inv_locate_b (as, am) (q, Oc # aaa, xs) ires"
  apply(simp only: inv_locate_b.simps in_middle.simps)
  apply(erule exE)+
  apply(rename_tac lm1 lm2 tn m ml mr rn)
  apply(rule_tac x = lm1 in exI, rule_tac x = lm2 in exI, 
      rule_tac x = tn in exI, rule_tac x = m in exI)
  apply(rule_tac x = "Suc ml" in exI, rule_tac x = "mr - 1" in exI,
      rule_tac x = rn in exI)
  apply(case_tac mr)
  apply simp_all
  done

lemma tape_nat[simp]:  "<[x::nat]> = Oc(Suc x)"
  apply(simp add: tape_of_nat_def tape_of_list_def)
  done

lemma inv_locate[simp]: "inv_locate_b (as, am) (q, aaa, Bk # xs) ires; n. xs = Bkn
             inv_locate_a (as, am) (Suc q, Bk # aaa, xs) ires"
  apply(simp add: inv_locate_b.simps inv_locate_a.simps)
  apply(rule_tac disjI2, rule_tac disjI1)
  apply(simp only: in_middle.simps at_begin_fst_bwtn.simps)
  apply(erule_tac exE)+
  apply(rename_tac lm1 n lm2 tn m ml mr rn)
  apply(rule_tac x = "lm1 @ [m]" in exI, rule_tac x = tn in exI, simp split: if_splits)
   apply(case_tac mr, simp_all)
   apply(cases "length am", simp_all)
   apply(case_tac lm2, simp_all add: tape_of_nl_cons split: if_splits)
     apply(cases am, simp_all)
    apply(case_tac n, simp_all)
   apply(case_tac n, simp_all)
  apply(case_tac mr, simp_all)
  apply(case_tac lm2, simp_all add: tape_of_nl_cons split: if_splits, auto)
   apply(case_tac [!] n, simp_all)
  done

lemma repeat_Bk_no_Oc[simp]: "(Oc # r = Bk  rn) = False"
  apply(cases rn, simp_all)
  done

lemma repeat_Bk[simp]: "(rna. Bk  rn = Bk # Bk  rna)  rn = 0"
  apply(cases rn, auto)
  done

lemma inv_locate_b_Oc_via_a[simp]: 
  assumes "inv_locate_a (as, lm) (q, l, Oc # r) ires"
  shows "inv_locate_b (as, lm) (q, Oc # l, r) ires"
proof -
  show ?thesis using assms unfolding inv_locate_a.simps inv_locate_b.simps
      at_begin_norm.simps at_begin_fst_bwtn.simps at_begin_fst_awtn.simps
    apply(simp only:in_middle.simps)
    apply(erule disjE, erule exE, erule exE, erule exE)
     apply(rename_tac Lm1 Lm2 Rn)
     apply(rule_tac x = Lm1 in exI, rule_tac x = "tl Lm2" in exI)
     apply(rule_tac x = 0 in exI, rule_tac x = "hd Lm2" in exI)
     apply(rule_tac x = 1 in exI, rule_tac x = "hd Lm2" in exI)
     apply(case_tac Lm2, force simp: tape_of_nl_cons )
     apply(case_tac "tl Lm2", simp_all)
     apply(case_tac Rn, auto simp: tape_of_nl_cons )
    apply(rename_tac tn rn)
    apply(rule_tac x = "lm @ replicate tn 0" in exI, 
        rule_tac x = "[]" in exI, 
        rule_tac x = "Suc tn" in exI, 
        rule_tac x = 0 in exI, auto simp add: replicate_append_same)
    apply(rule_tac x = "Suc 0" in exI, auto)
    done
qed

lemma length_equal: "xs = ys  length xs = length ys"
  by auto

lemma inv_locate_a_Bk_via_b[simp]: "inv_locate_b (as, am) (q, aaa, Bk # xs) ires; 
                ¬ (n. xs = Bkn) 
        inv_locate_a (as, am) (Suc q, Bk # aaa, xs) ires"
  supply [[simproc del: defined_all]]
  apply(simp add: inv_locate_b.simps inv_locate_a.simps)
  apply(rule_tac disjI1)
  apply(simp only: in_middle.simps at_begin_norm.simps)
  apply(erule_tac exE)+
  apply(rename_tac lm1 lm2 tn m ml mr rn)
  apply(rule_tac x = "lm1 @ [m]" in exI, rule_tac x = lm2 in exI, simp)
  apply(subgoal_tac "tn = 0", simp , auto split: if_splits)
    apply(simp add: tape_of_nl_cons)
   apply(drule_tac length_equal, simp)
   apply(cases "length am", simp_all, erule_tac x = rn in allE, simp)
  apply(drule_tac length_equal, simp)
  apply(case_tac "(Suc (length lm1) - length am)", simp_all)
  apply(case_tac lm2, simp, simp)
  done

lemma locate_b_2_a[intro]: 
  "inv_locate_b (as, am) (q, aaa, Bk # xs) ires
     inv_locate_a (as, am) (Suc q, Bk # aaa, xs) ires"
  apply(cases " n. xs = Bkn", simp, simp)
  done


lemma inv_locate_b_Bk[simp]:  "inv_locate_b (as, am) (q, l, []) ires 
             inv_locate_b (as, am) (q, l, [Bk]) ires"
  by(force simp add: inv_locate_b.simps in_middle.simps)

(*inv: from locate_b to after_write*)

lemma div_rounding_down[simp]: "(2*q - Suc 0) div 2 = (q - 1)" "(Suc (2*q)) div 2 = q"
  by arith+

lemma even_plus_one_odd[simp]: "x mod 2 = 0  Suc x mod 2 = Suc 0"
  by arith

lemma odd_plus_one_even[simp]: "x mod 2 = Suc 0  Suc x mod 2 = 0"
  by arith

lemma locate_b_2_locate_a[simp]: 
  "q > 0;  inv_locate_b (as, am) (q - Suc 0, aaa, Bk # xs) ires
     inv_locate_a (as, am) (q, Bk # aaa, xs) ires"
  apply(insert locate_b_2_a [of as am "q - 1" aaa xs ires], simp)
  done

(*inv: from locate_b to after_write*)

lemma findnth_inv_layout_of_via_crsp[simp]:
  "crsp (layout_of ap) (as, lm) (s, l, r) ires
   findnth_inv (layout_of ap) n (as, lm) (Suc 0, l, r) ires"
  by(auto simp: crsp.simps findnth_inv.simps inv_locate_a.simps
      at_begin_norm.simps at_begin_fst_awtn.simps at_begin_fst_bwtn.simps)

lemma findnth_correct_pre: 
  assumes layout: "ly = layout_of ap"
    and crsp: "crsp ly (as, lm) (s, l, r) ires"
    and not0: "n > 0"
    and f: "f = (λ stp. (steps (Suc 0, l, r) (findnth n, 0) stp, n))"
    and P: "P = (λ ((s, l, r), n). s = Suc (2 * n))"
    and Q: "Q = (λ ((s, l, r), n). findnth_inv ly n (as, lm) (s, l, r) ires)"
  shows " stp. P (f stp)  Q (f stp)"
proof(rule_tac LE = findnth_LE in halt_lemma2)
  show "wf findnth_LE"  by(intro wf_findnth_LE)
next
  show "Q (f 0)"
    using crsp layout
    apply(simp add: f P Q steps.simps)
    done
next
  show "¬ P (f 0)"
    using not0
    apply(simp add: f P steps.simps)
    done
next
  have "¬ P (f na)  Q (f na)  Q (f (Suc na))  (f (Suc na), f na) 
         findnth_LE" for na
  proof(simp add: f, 
      cases "steps (Suc 0, l, r) (findnth n, 0) na", simp add: P)
    fix na a b c
    assume "a  Suc (2 * n)  Q ((a, b, c), n)"
    thus  "Q (step (a, b, c) (findnth n, 0), n)  
        ((step (a, b, c) (findnth n, 0), n), (a, b, c), n)  findnth_LE"
      apply(cases c, case_tac [2] "hd c")
        apply(simp_all add: step.simps findnth_LE_def Q findnth_inv.simps mod_2  lex_pair_def split: if_splits)
         apply(auto simp: mod_ex1 mod_ex2)
      done
  qed
  thus "n. ¬ P (f n)  Q (f n) 
        Q (f (Suc n))  (f (Suc n), f n)  findnth_LE" by blast
qed

lemma inv_locate_a_via_crsp[simp]:
  "crsp ly (as, lm) (s, l, r) ires  inv_locate_a (as, lm) (0, l, r) ires"
  apply(auto simp: crsp.simps inv_locate_a.simps at_begin_norm.simps)
  done

lemma findnth_correct: 
  assumes layout: "ly = layout_of ap"
    and crsp: "crsp ly (as, lm) (s, l, r) ires"
  shows " stp l' r'. steps (Suc 0, l, r) (findnth n, 0) stp = (Suc (2 * n), l', r')
               inv_locate_a (as, lm) (n, l', r') ires"
  using crsp
  apply(cases "n = 0")
   apply(rule_tac x = 0 in exI, auto simp: steps.simps)
  using assms
  apply(drule_tac findnth_correct_pre, auto)
  using findnth_inv.simps by auto

fun inc_inv :: "nat  inc_inv_t"
  where
    "inc_inv n (as, lm) (s, l, r) ires =
              (let lm' = abc_lm_s lm n (Suc (abc_lm_v lm n)) in
                if s = 0 then False
                else if s = 1 then 
                   inv_locate_a (as, lm) (n, l, r) ires
                else if s = 2 then 
                   inv_locate_b (as, lm) (n, l, r) ires
                else if s = 3 then 
                   inv_after_write (as, lm') (s, l, r) ires
                else if s = Suc 3 then 
                   inv_after_move (as, lm') (s, l, r) ires
                else if s = Suc 4 then 
                   inv_after_clear (as, lm') (s, l, r) ires
                else if s = Suc (Suc 4) then 
                   inv_on_right_moving (as, lm') (s, l, r) ires
                else if s = Suc (Suc 5) then 
                   inv_on_left_moving (as, lm') (s, l, r) ires
                else if s = Suc (Suc (Suc 5)) then 
                   inv_check_left_moving (as, lm') (s, l, r) ires
                else if s = Suc (Suc (Suc (Suc 5))) then 
                   inv_after_left_moving (as, lm') (s, l, r) ires
                else if s = Suc (Suc (Suc (Suc (Suc 5)))) then 
                   inv_stop (as, lm') (s, l, r) ires
                else False)"


fun abc_inc_stage1 :: "config  nat"
  where
    "abc_inc_stage1 (s, l, r) = 
            (if s = 0 then 0
             else if s  2 then 5
             else if s  6 then 4
             else if s  8 then 3
             else if s = 9 then 2
             else 1)"

fun abc_inc_stage2 :: "config  nat"
  where
    "abc_inc_stage2 (s, l, r) =
                (if s = 1 then 2
                 else if s = 2 then 1
                 else if s = 3 then length r
                 else if s = 4 then length r
                 else if s = 5 then length r
                 else if s = 6 then 
                                  if r  [] then length r
                                  else 1
                 else if s = 7 then length l
                 else if s = 8 then length l
                 else 0)"

fun abc_inc_stage3 :: "config   nat"
  where
    "abc_inc_stage3 (s, l, r) = (
              if s = 4 then 4
              else if s = 5 then 3
              else if s = 6 then 
                   if r  []  hd r = Oc then 2
                   else 1
              else if s = 3 then 0
              else if s = 2 then length r
              else if s = 1 then 
                      if (r  []  hd r = Oc) then 0
                      else 1
              else 10 - s)"


definition inc_measure :: "config  nat × nat × nat"
  where
    "inc_measure c = 
    (abc_inc_stage1 c, abc_inc_stage2 c, abc_inc_stage3 c)"

definition lex_triple :: 
  "((nat × (nat × nat)) × (nat × (nat × nat))) set"
  where "lex_triple  less_than <*lex*> lex_pair"

definition inc_LE :: "(config × config) set"
  where
    "inc_LE  (inv_image lex_triple inc_measure)"

declare inc_inv.simps[simp del]

lemma wf_inc_le[intro]: "wf inc_LE"
  by(auto simp: inc_LE_def lex_triple_def lex_pair_def)

lemma inv_locate_b_2_after_write[simp]:
  assumes "inv_locate_b (as, am) (n, aaa, Bk # xs) ires"
  shows "inv_after_write (as, abc_lm_s am n (Suc (abc_lm_v am n))) (s, aaa, Oc # xs) ires"
proof -
  from assms show ?thesis
    apply(auto simp: in_middle.simps inv_after_write.simps 
        abc_lm_v.simps abc_lm_s.simps inv_locate_b.simps simp del:split_head_repeat)
     apply(rename_tac lm1 lm2 m ml mr rn)
     apply(case_tac [!] mr, auto split: if_splits)
    apply(rename_tac lm1 lm2 m rn)
    apply(rule_tac x = rn in exI, rule_tac x = "Suc m" in exI,
        rule_tac x = "lm1" in exI, simp)
    apply(rule_tac x = "lm2" in exI)
    apply(simp only: Suc_diff_le exp_ind)
    by(subgoal_tac "lm2 = []"; force dest:length_equal)
qed

(*inv: from after_write to after_move*)
lemma inv_after_move_Oc_via_write[simp]: "inv_after_write (as, lm) (x, l, Oc # r) ires
                 inv_after_move (as, lm) (y, Oc # l, r) ires"
  apply(auto simp:inv_after_move.simps inv_after_write.simps split: if_splits)
  done

lemma inv_after_write_Suc[simp]: "inv_after_write (as, abc_lm_s am n (Suc (abc_lm_v am n)
                )) (x, aaa, Bk # xs) ires = False"
  "inv_after_write (as, abc_lm_s am n (Suc (abc_lm_v am n))) 
                        (x, aaa, []) ires = False"
   apply(auto simp: inv_after_write.simps )
  done

(*inv: from after_move to after_clear*)
lemma inv_after_clear_Bk_via_Oc[simp]: "inv_after_move (as, lm) (s, l, Oc # r) ires
                 inv_after_clear (as, lm) (s', l, Bk # r) ires"
  apply(auto simp: inv_after_move.simps inv_after_clear.simps split: if_splits)
  done


lemma inv_after_move_2_inv_on_left_moving[simp]:  
  assumes "inv_after_move (as, lm) (s, l, Bk # r) ires"
  shows "(l = []  
         inv_on_left_moving (as, lm) (s', [], Bk # Bk # r) ires) 
      (l  []  
         inv_on_left_moving (as, lm) (s', tl l, hd l # Bk # r) ires)"
proof (cases l)
  case (Cons a list)
  from assms Cons show ?thesis
    apply(simp only: inv_after_move.simps inv_on_left_moving.simps)
    apply(rule conjI, force, rule impI, rule disjI1, simp only: inv_on_left_moving_norm.simps)
    apply(erule exE)+
    apply(rename_tac rn m lm1 lm2)
    apply(subgoal_tac "lm2 = []")
     apply(rule_tac x = lm1 in exI, rule_tac x = lm2 in exI,  
        rule_tac x = m in exI, rule_tac x = m in exI, 
        rule_tac x = 1 in exI,  
        rule_tac x = "rn - 1" in exI)
     apply (auto split:if_splits)
       apply(case_tac [1-2] rn, simp_all)
    by(case_tac [!] lm2, simp_all add: tape_of_nl_cons split: if_splits)
next
  case Nil thus ?thesis using assms
    unfolding inv_after_move.simps inv_on_left_moving.simps
    by (auto split:if_splits)
qed


lemma inv_after_move_2_inv_on_left_moving_B[simp]: 
  "inv_after_move (as, lm) (s, l, []) ires
       (l = []  inv_on_left_moving (as, lm) (s', [], [Bk]) ires) 
          (l  []  inv_on_left_moving (as, lm) (s', tl l, [hd l]) ires)"
  apply(simp only: inv_after_move.simps inv_on_left_moving.simps)
  apply(subgoal_tac "l  []", rule conjI, simp, rule impI, rule disjI1,
      simp only: inv_on_left_moving_norm.simps)
   apply(erule exE)+
   apply(rename_tac rn m lm1 lm2)
   apply(subgoal_tac "lm2 = []")
    apply(rule_tac x = lm1 in exI, rule_tac x = lm2 in exI,  
      rule_tac x = m in exI, rule_tac x = m in exI, 
      rule_tac x = 1 in exI, rule_tac x = "rn - 1" in exI, force)
   apply(metis append_Cons list.distinct(1) list.exhaust replicate_Suc tape_of_nl_cons)
  apply(metis append_Cons list.distinct(1) replicate_Suc)
  done

lemma inv_after_clear_2_inv_on_right_moving[simp]: 
  "inv_after_clear (as, lm) (x, l, Bk # r) ires
       inv_on_right_moving (as, lm) (y, Bk # l, r) ires"
  apply(auto simp: inv_after_clear.simps inv_on_right_moving.simps simp del:split_head_repeat)
  apply(rename_tac rn m lm1 lm2)
  apply(subgoal_tac "lm2  []")
   apply(rule_tac x = "lm1 @ [m]" in exI, rule_tac x = "tl lm2" in exI, 
      rule_tac x = "hd lm2" in exI, simp del:split_head_repeat)
   apply(rule_tac x = 0 in exI, rule_tac x = "hd lm2" in exI)
   apply(simp, rule conjI)
    apply(case_tac [!] "lm2::nat list", auto)
    apply(case_tac rn, auto split: if_splits simp: tape_of_nl_cons)
   apply(case_tac [!] rn, simp_all)
  done

(*inv: from on_right_moving to on_right_moving*)
lemma inv_on_right_moving_Oc[simp]: "inv_on_right_moving (as, lm) (x, l, Oc # r) ires
       inv_on_right_moving (as, lm) (y, Oc # l, r) ires"
  apply(auto simp: inv_on_right_moving.simps)
   apply(rename_tac lm1 lm2 ml mr rn)
   apply(rule_tac x = lm1 in exI, rule_tac x = lm2 in exI, 
      rule_tac x = "ml + mr" in exI, simp)
   apply(rule_tac x = "Suc ml" in exI, 
      rule_tac x = "mr - 1" in exI, simp) 
   apply (metis One_nat_def Suc_pred cell.distinct(1) empty_replicate list.inject
      list.sel(3) neq0_conv self_append_conv2 tl_append2 tl_replicate)
  apply(rule_tac x = lm1 in exI, rule_tac x = "[]" in exI, 
      rule_tac x = "ml + mr" in exI, simp)
  apply(rule_tac x = "Suc ml" in exI, 
      rule_tac x = "mr - 1" in exI)
  apply (auto simp add: Cons_replicate_eq)
  done

lemma inv_on_right_moving_2_inv_on_right_moving[simp]: 
  "inv_on_right_moving (as, lm) (x, l, Bk # r) ires
      inv_after_write (as, lm) (y, l, Oc # r) ires"
  apply(auto simp: inv_on_right_moving.simps inv_after_write.simps)
  by (metis append.left_neutral append_Cons )

lemma inv_on_right_moving_singleton_Bk[simp]: "inv_on_right_moving (as, lm) (x, l, []) ires 
             inv_on_right_moving (as, lm) (y, l, [Bk]) ires"
  apply(auto simp: inv_on_right_moving.simps)
  by fastforce

(*inv: from on_left_moving to on_left_moving*)
lemma no_inv_on_left_moving_in_middle_B_Oc[simp]: "inv_on_left_moving_in_middle_B (as, lm) 
               (s, l, Oc # r) ires = False"
  by(auto simp: inv_on_left_moving_in_middle_B.simps )

lemma no_inv_on_left_moving_norm_Bk[simp]: "inv_on_left_moving_norm (as, lm) (s, l, Bk # r) ires 
             = False"
  by(auto simp: inv_on_left_moving_norm.simps)

lemma inv_on_left_moving_in_middle_B_Bk[simp]: 
  "inv_on_left_moving_norm (as, lm) (s, l, Oc # r) ires;
    hd l = Bk; l  []  
     inv_on_left_moving_in_middle_B (as, lm) (s, tl l, Bk # Oc # r) ires"
  apply(cases l, simp, simp)
  apply(simp only: inv_on_left_moving_norm.simps 
      inv_on_left_moving_in_middle_B.simps)
  apply(erule_tac exE)+ unfolding tape_of_nl_cons
  apply(rename_tac a list lm1 lm2 m ml mr rn)
  apply(rule_tac x = lm1 in exI, rule_tac x = "m # lm2" in exI, auto)
   apply(auto simp: tape_of_nl_cons split: if_splits)
  done

lemma inv_on_left_moving_norm_Oc_Oc[simp]: "inv_on_left_moving_norm (as, lm) (s, l, Oc # r) ires; 
                hd l = Oc; l  []
             inv_on_left_moving_norm (as, lm) 
                                        (s, tl l, Oc # Oc # r) ires"
  apply(simp only: inv_on_left_moving_norm.simps)
  apply(erule exE)+
  apply(rename_tac lm1 lm2 m ml mr rn)
  apply(rule_tac x = lm1 in exI, rule_tac x = lm2 in exI, 
      rule_tac x = m in exI, rule_tac x = "ml - 1" in exI,
      rule_tac x = "Suc mr" in exI, rule_tac x = rn in exI, simp)
  apply(case_tac ml, auto simp: split: if_splits)
  done

lemma inv_on_left_moving_in_middle_B_Bk_Oc[simp]: "inv_on_left_moving_norm (as, lm) (s, [], Oc # r) ires
      inv_on_left_moving_in_middle_B (as, lm) (s, [], Bk # Oc # r) ires"
  by(auto simp: inv_on_left_moving_norm.simps 
      inv_on_left_moving_in_middle_B.simps split: if_splits)

lemma inv_on_left_moving_Oc_cases[simp]:"inv_on_left_moving (as, lm) (s, l, Oc # r) ires
     (l = []  inv_on_left_moving (as, lm) (s, [], Bk # Oc # r) ires)
   (l  []  inv_on_left_moving (as, lm) (s, tl l, hd l # Oc # r) ires)"
  apply(simp add: inv_on_left_moving.simps)
  apply(cases "l  []", rule conjI, simp, simp)
   apply(cases "hd l", simp, simp, simp)
  done

lemma from_on_left_moving_to_check_left_moving[simp]: "inv_on_left_moving_in_middle_B (as, lm) 
                                      (s, Bk # list, Bk # r) ires
           inv_check_left_moving_on_leftmost (as, lm) 
                                      (s', list, Bk # Bk # r) ires"
  apply(simp only: inv_on_left_moving_in_middle_B.simps inv_check_left_moving_on_leftmost.simps)
  apply(erule_tac exE)+
  apply(rename_tac lm1 lm2 rn)
  apply(case_tac "rev lm1", simp_all)
  apply(case_tac "tl (rev lm1)", simp_all add: tape_of_nat_def tape_of_list_def)
  done

lemma inv_check_left_moving_in_middle_no_Bk[simp]:
  "inv_check_left_moving_in_middle (as, lm) (s, l, Bk # r) ires= False"
  by(auto simp: inv_check_left_moving_in_middle.simps )

lemma inv_check_left_moving_on_leftmost_Bk_Bk[simp]: 
  "inv_on_left_moving_in_middle_B (as, lm) (s, [], Bk # r) ires 
  inv_check_left_moving_on_leftmost (as, lm) (s', [], Bk # Bk # r) ires"
  apply(auto simp: inv_on_left_moving_in_middle_B.simps 
      inv_check_left_moving_on_leftmost.simps split: if_splits)
  done

lemma inv_check_left_moving_on_leftmost_no_Oc[simp]: "inv_check_left_moving_on_leftmost (as, lm) 
                                       (s, list, Oc # r) ires= False"
  by(auto simp: inv_check_left_moving_on_leftmost.simps split: if_splits)

lemma inv_check_left_moving_in_middle_Oc_Bk[simp]: "inv_on_left_moving_in_middle_B (as, lm) 
                                         (s, Oc # list, Bk # r) ires
  inv_check_left_moving_in_middle (as, lm) (s', list, Oc # Bk # r) ires"
  apply(auto simp: inv_on_left_moving_in_middle_B.simps 
      inv_check_left_moving_in_middle.simps  split: if_splits)
  done

lemma inv_on_left_moving_2_check_left_moving[simp]:
  "inv_on_left_moving (as, lm) (s, l, Bk # r) ires
  (l = []  inv_check_left_moving (as, lm) (s', [], Bk # Bk # r) ires)
  (l  []  
      inv_check_left_moving (as, lm) (s', tl l, hd l # Bk # r) ires)"
  by (cases l;cases "hd l", auto simp: inv_on_left_moving.simps inv_check_left_moving.simps)

lemma inv_on_left_moving_norm_no_empty[simp]: "inv_on_left_moving_norm (as, lm) (s, l, []) ires = False"
  apply(auto simp: inv_on_left_moving_norm.simps)
  done

lemma inv_on_left_moving_no_empty[simp]: "inv_on_left_moving (as, lm) (s, l, []) ires = False"
  apply(simp add: inv_on_left_moving.simps)
  apply(simp add: inv_on_left_moving_in_middle_B.simps)
  done

lemma 
  inv_check_left_moving_in_middle_2_on_left_moving_in_middle_B[simp]:
  assumes "inv_check_left_moving_in_middle (as, lm) (s, Bk # list, Oc # r) ires"
  shows "inv_on_left_moving_in_middle_B (as, lm) (s', list, Bk # Oc # r) ires"
  using assms
  apply(simp only: inv_check_left_moving_in_middle.simps 
      inv_on_left_moving_in_middle_B.simps)
  apply(erule_tac exE)+
  apply(rename_tac lm1 lm2 r' rn)
  apply(rule_tac x = "rev (tl (rev lm1))" in exI, 
      rule_tac x = "[hd (rev lm1)] @ lm2" in exI, auto)
       apply(case_tac [!] "rev lm1",case_tac [!] "tl (rev lm1)")
                      apply(simp_all add: tape_of_nat_def tape_of_list_def tape_of_nat_list.simps)
   apply(case_tac [1] lm2, auto simp:tape_of_nat_def)
  apply(case_tac lm2, auto simp:tape_of_nat_def)
  done

lemma inv_check_left_moving_in_middle_Bk_Oc[simp]: 
  "inv_check_left_moving_in_middle (as, lm) (s, [], Oc # r) ires
     inv_check_left_moving_in_middle (as, lm) (s', [Bk], Oc # r) ires"
  apply(auto simp: inv_check_left_moving_in_middle.simps )
  done

lemma inv_on_left_moving_norm_Oc_Oc_via_middle[simp]: "inv_check_left_moving_in_middle (as, lm) 
                       (s, Oc # list, Oc # r) ires
    inv_on_left_moving_norm (as, lm) (s', list, Oc # Oc # r) ires"
  apply(auto simp: inv_check_left_moving_in_middle.simps 
      inv_on_left_moving_norm.simps)
  apply(rename_tac lm1 lm2 rn)
  apply(rule_tac x = "rev (tl (rev lm1))" in exI, 
      rule_tac x = lm2 in exI, rule_tac x = "hd (rev lm1)" in exI)
  apply(rule_tac conjI)
   apply(case_tac "rev lm1", simp, simp)
  apply(rule_tac x = "hd (rev lm1) - 1" in exI, auto)
   apply(rule_tac [!] x = "Suc (Suc 0)" in exI, simp)
   apply(case_tac [!] "rev lm1", simp_all)
   apply(case_tac [!] "last lm1", simp_all add: tape_of_nl_cons split: if_splits)
  done

lemma inv_check_left_moving_Oc_cases[simp]: "inv_check_left_moving (as, lm) (s, l, Oc # r) ires
 (l = []  inv_on_left_moving (as, lm) (s', [], Bk # Oc # r) ires) 
   (l  []  inv_on_left_moving (as, lm) (s', tl l, hd l # Oc # r) ires)"
  apply(cases l;cases "hd l", auto simp: inv_check_left_moving.simps inv_on_left_moving.simps)
  done

(*inv: check_left_moving to after_left_moving*)
lemma inv_after_left_moving_Bk_via_check[simp]: "inv_check_left_moving (as, lm) (s, l, Bk # r) ires
                 inv_after_left_moving (as, lm) (s', Bk # l, r) ires"
  apply(auto simp: inv_check_left_moving.simps 
      inv_check_left_moving_on_leftmost.simps inv_after_left_moving.simps)
  done


lemma inv_after_left_moving_Bk_empty_via_check[simp]:"inv_check_left_moving (as, lm) (s, l, []) ires
       inv_after_left_moving (as, lm) (s', Bk # l, []) ires"
  by(simp add: inv_check_left_moving.simps  
      inv_check_left_moving_in_middle.simps 
      inv_check_left_moving_on_leftmost.simps)

(*inv: after_left_moving to inv_stop*)
lemma inv_stop_Bk_move[simp]: "inv_after_left_moving (as, lm) (s, l, Bk # r) ires
        inv_stop (as, lm) (s', Bk # l, r) ires"
  apply(auto simp: inv_after_left_moving.simps inv_stop.simps)
  done

lemma inv_stop_Bk_empty[simp]: "inv_after_left_moving (as, lm) (s, l, []) ires
              inv_stop (as, lm) (s', Bk # l, []) ires"
  by(auto simp: inv_after_left_moving.simps)

(*inv: stop to stop*)
lemma inv_stop_indep_fst[simp]: "inv_stop (as, lm) (x, l, r) ires  
               inv_stop (as, lm) (y, l, r) ires"
  apply(simp add: inv_stop.simps)
  done

lemma inv_after_clear_no_Oc[simp]: "inv_after_clear (as, lm) (s, aaa, Oc # xs) ires= False"
  apply(auto simp: inv_after_clear.simps )
  done

lemma inv_after_left_moving_no_Oc[simp]: 
  "inv_after_left_moving (as, lm) (s, aaa, Oc # xs) ires = False"
  by(auto simp: inv_after_left_moving.simps  )

lemma inv_after_clear_Suc_nonempty[simp]:
  "inv_after_clear (as, abc_lm_s lm n (Suc (abc_lm_v lm n))) (s, b, []) ires = False"
  apply(auto simp: inv_after_clear.simps)
  done

lemma inv_on_left_moving_Suc_nonempty[simp]: "inv_on_left_moving (as, abc_lm_s lm n (Suc (abc_lm_v lm n))) 
           (s, b, Oc # list) ires  b  []"
  apply(auto simp: inv_on_left_moving.simps inv_on_left_moving_norm.simps split: if_splits)
  done

lemma inv_check_left_moving_Suc_nonempty[simp]:
  "inv_check_left_moving (as, abc_lm_s lm n (Suc (abc_lm_v lm n))) (s, b, Oc # list) ires  b  []"
  apply(auto simp: inv_check_left_moving.simps inv_check_left_moving_in_middle.simps split: if_splits)
  done

lemma tinc_correct_pre:
  assumes layout: "ly = layout_of ap"
    and inv_start: "inv_locate_a (as, lm) (n, l, r) ires"
    and lm': "lm' = abc_lm_s lm n (Suc (abc_lm_v lm n))"
    and f: "f = steps (Suc 0, l, r) (tinc_b, 0)"
    and P: "P = (λ (s, l, r). s = 10)"
    and Q: "Q = (λ (s, l, r). inc_inv n (as, lm) (s, l, r) ires)" 
  shows " stp. P (f stp)  Q (f stp)"
proof(rule_tac LE = inc_LE in halt_lemma2)
  show "wf inc_LE" by(auto)
next
  show "Q (f 0)"
    using inv_start
    by(simp add: f P Q steps.simps inc_inv.simps)
next
  show "¬ P (f 0)"
    by(simp add: f P steps.simps)
next
  have "¬ P (f n)  Q (f n)  Q (f (Suc n))  (f (Suc n), f n) 
         inc_LE" for n
  proof(simp add: f, 
      cases "steps (Suc 0, l, r) (tinc_b, 0) n", simp add: P)
    fix n a b c
    assume 10: "a  10  Q (a, b, c)"
    thus  "Q (step (a, b, c) (tinc_b, 0))  (step (a, b, c) (tinc_b, 0), a, b, c)  inc_LE"
      apply(simp add:Q)
      apply(simp add: inc_inv.simps)
      apply(cases c; cases "hd c")
         apply(auto simp: Let_def step.simps tinc_b_def split: if_splits) (* ~ 12 sec *)
                          apply(simp_all add: inc_inv.simps inc_LE_def lex_triple_def lex_pair_def
          inc_measure_def numeral)
      done
  qed
  thus "n. ¬ P (f n)  Q (f n)  Q (f (Suc n))  (f (Suc n), f n)  inc_LE" by blast
qed

lemma tinc_correct: 
  assumes layout: "ly = layout_of ap"
    and inv_start: "inv_locate_a (as, lm) (n, l, r) ires"
    and lm': "lm' = abc_lm_s lm n (Suc (abc_lm_v lm n))"
  shows " stp l' r'. steps (Suc 0, l, r) (tinc_b, 0) stp = (10, l', r')
               inv_stop (as, lm') (10, l', r') ires"
  using assms
  apply(drule_tac tinc_correct_pre, auto)
  apply(rule_tac x = stp in exI, simp)
  apply(simp add: inc_inv.simps)
  done

lemma is_even_4[simp]: "(4::nat) * n mod 2 = 0"
  apply(arith)
  done

lemma crsp_step_inc_pre:
  assumes layout: "ly = layout_of ap"
    and crsp: "crsp ly (as, lm) (s, l, r) ires"
    and aexec: "abc_step_l (as, lm) (Some (Inc n)) = (asa, lma)"
  shows " stp k. steps (Suc 0, l, r) (findnth n @ shift tinc_b (2 * n), 0) stp 
        = (2*n + 10, Bk # Bk # ires, <lma> @ Bkk)  stp > 0"
proof -
  have " stp l' r'. steps (Suc 0, l, r) (findnth n, 0) stp = (Suc (2 * n), l', r')
     inv_locate_a (as, lm) (n, l', r') ires"
    using assms
    apply(rule_tac findnth_correct, simp_all add: crsp layout)
    done
  from this obtain stp l' r' where a:
    "steps (Suc 0, l, r) (findnth n, 0) stp = (Suc (2 * n), l', r')
     inv_locate_a (as, lm) (n, l', r') ires" by blast
  moreover have
    " stp la ra. steps (Suc 0, l', r') (tinc_b, 0) stp = (10, la, ra)
                         inv_stop (as, lma) (10, la, ra) ires"
    using assms a
  proof(rule_tac lm' = lma and n = n and lm = lm and ly = ly and ap = ap in tinc_correct,
      simp, simp)
    show "lma = abc_lm_s lm n (Suc (abc_lm_v lm n))"
      using aexec
      apply(simp add: abc_step_l.simps)
      done
  qed
  from this obtain stpa la ra where b:
    "steps (Suc 0, l', r') (tinc_b, 0) stpa = (10, la, ra)
     inv_stop (as, lma) (10, la, ra) ires" by blast
  from a b show "stp k. steps (Suc 0, l, r) (findnth n @ shift tinc_b (2 * n), 0) stp
    = (2 * n + 10, Bk # Bk # ires, <lma> @ Bk  k)  stp > 0"
    apply(rule_tac x = "stp + stpa" in exI)
    using tm_append_steps[of "Suc 0" l r "findnth n" stp l' r' tinc_b stpa 10 la ra "length (findnth n) div 2"]
    apply(simp add: length_findnth inv_stop.simps)
    apply(cases stpa, simp_all add: steps.simps)
    done
qed 

lemma crsp_step_inc:
  assumes layout: "ly = layout_of ap"
    and crsp: "crsp ly (as, lm) (s, l, r) ires"
    and fetch: "abc_fetch as ap = Some (Inc n)"
  shows "stp > 0. crsp ly (abc_step_l (as, lm) (Some (Inc n)))
  (steps (s, l, r) (ci ly (start_of ly as) (Inc n), start_of ly as - Suc 0) stp) ires"
proof(cases "(abc_step_l (as, lm) (Some (Inc n)))")
  fix a b
  assume aexec: "abc_step_l (as, lm) (Some (Inc n)) = (a, b)"
  then have " stp k. steps (Suc 0, l, r) (findnth n @ shift tinc_b (2 * n), 0) stp 
        = (2*n + 10, Bk # Bk # ires, <b> @ Bkk)  stp > 0"
    using assms
    apply(rule_tac crsp_step_inc_pre, simp_all)
    done
  thus "?thesis"
    using assms aexec
    apply(erule_tac exE)
    apply(erule_tac exE)
    apply(erule_tac conjE)
    apply(rename_tac stp k)
    apply(rule_tac x = stp in exI, simp add: ci.simps tm_shift_eq_steps)
    apply(drule_tac off = "(start_of (layout_of ap) as - Suc 0)" in tm_shift_eq_steps)
     apply(auto simp: crsp.simps abc_step_l.simps fetch start_of_Suc1)
    done
qed

subsection‹Crsp of Dec n e›

type_synonym dec_inv_t = "(nat * nat list)  config  cell list   bool"

fun dec_first_on_right_moving :: "nat  dec_inv_t"
  where
    "dec_first_on_right_moving n (as, lm) (s, l, r) ires = 
               ( lm1 lm2 m ml mr rn. lm = lm1 @ [m] @ lm2  
         ml + mr = Suc m  length lm1 = n  ml > 0  m > 0 
             (if lm1 = [] then l = Ocml @ Bk # Bk # ires
                          else  l = Ocml @ [Bk] @ <rev lm1> @ Bk # Bk # ires)  
    ((r = Ocmr @ [Bk] @ <lm2> @ Bkrn)  (r = Ocmr  lm2 = [])))"

fun dec_on_right_moving :: "dec_inv_t"
  where
    "dec_on_right_moving (as, lm) (s, l, r) ires =  
   ( lm1 lm2 m ml mr rn. lm = lm1 @ [m] @ lm2  
                             ml + mr = Suc (Suc m) 
   (if lm1 = [] then l = Ocml@ Bk # Bk # ires
                else  l = Ocml @ [Bk] @ <rev lm1> @ Bk # Bk # ires)  
   ((r = Ocmr @ [Bk] @ <lm2> @ Bkrn)  (r = Ocmr  lm2 = [])))"

fun dec_after_clear :: "dec_inv_t"
  where
    "dec_after_clear (as, lm) (s, l, r) ires = 
              ( lm1 lm2 m ml mr rn. lm = lm1 @ [m] @ lm2  
                ml + mr = Suc m  ml = Suc m  r  []  r  [] 
               (if lm1 = [] then l = Ocml@ Bk # Bk # ires
                            else l = Ocml @ [Bk] @ <rev lm1> @ Bk # Bk # ires)  
               (tl r = Bk # <lm2> @ Bkrn  tl r = []  lm2 = []))"

fun dec_after_write :: "dec_inv_t"
  where
    "dec_after_write (as, lm) (s, l, r) ires = 
         ( lm1 lm2 m ml mr rn. lm = lm1 @ [m] @ lm2  
       ml + mr = Suc m  ml = Suc m  lm2  [] 
       (if lm1 = [] then l = Bk # Ocml @ Bk # Bk # ires
                    else l = Bk # Ocml @ [Bk] @ <rev lm1> @ Bk # Bk # ires)  
       tl r = <lm2> @ Bkrn)"

fun dec_right_move :: "dec_inv_t"
  where
    "dec_right_move (as, lm) (s, l, r) ires = 
        ( lm1 lm2 m ml mr rn. lm = lm1 @ [m] @ lm2 
             ml = Suc m  mr = (0::nat)  
              (if lm1 = [] then l = Bk # Ocml @ Bk # Bk # ires
                          else l = Bk # Ocml @ [Bk] @ <rev lm1> @ Bk # Bk # ires) 
            (r = Bk # <lm2> @ Bkrn  r = []  lm2 = []))"

fun dec_check_right_move :: "dec_inv_t"
  where
    "dec_check_right_move (as, lm) (s, l, r) ires = 
        ( lm1 lm2 m ml mr rn. lm = lm1 @ [m] @ lm2  
           ml = Suc m  mr = (0::nat)  
           (if lm1 = [] then l = Bk # Bk # Ocml @ Bk # Bk # ires
                       else l = Bk # Bk # Ocml @ [Bk] @ <rev lm1> @ Bk # Bk # ires)  
           r = <lm2> @ Bkrn)"

fun dec_left_move :: "dec_inv_t"
  where
    "dec_left_move (as, lm) (s, l, r) ires = 
    ( lm1 m rn. (lm::nat list) = lm1 @ [m::nat]    
    rn > 0  
   (if lm1 = [] then l = Bk # OcSuc m @ Bk # Bk # ires
    else l = Bk # OcSuc m @ Bk # <rev lm1> @ Bk # Bk # ires)  r = Bkrn)"

declare
  dec_on_right_moving.simps[simp del] dec_after_clear.simps[simp del] 
  dec_after_write.simps[simp del] dec_left_move.simps[simp del] 
  dec_check_right_move.simps[simp del] dec_right_move.simps[simp del] 
  dec_first_on_right_moving.simps[simp del]

fun inv_locate_n_b :: "inc_inv_t"
  where
    "inv_locate_n_b (as, lm) (s, l, r) ires= 
    ( lm1 lm2 tn m ml mr rn. lm @ 0tn = lm1 @ [m] @ lm2  
     length lm1 = s  m + 1 = ml + mr  
     ml = 1  tn = s + 1 - length lm 
     (if lm1 = [] then l = Ocml @ Bk # Bk # ires
      else l = Ocml @ Bk # <rev lm1> @ Bk # Bk # ires)  
     (r = Ocmr @ [Bk] @ <lm2>@ Bkrn  (lm2 = []  r = Ocmr))
  )"

fun dec_inv_1 :: "layout  nat  nat  dec_inv_t"
  where
    "dec_inv_1 ly n e (as, am) (s, l, r) ires = 
           (let ss = start_of ly as in
            let am' = abc_lm_s am n (abc_lm_v am n - Suc 0) in
            let am'' = abc_lm_s am n (abc_lm_v am n) in
              if s = start_of ly e then inv_stop (as, am'') (s, l, r) ires
              else if s = ss then False
              else if s = ss + 2 * n + 1 then 
                  inv_locate_b (as, am) (n, l, r) ires
              else if s = ss + 2 * n + 13 then 
                  inv_on_left_moving (as, am'') (s, l, r) ires
              else if s = ss + 2 * n + 14 then 
                  inv_check_left_moving (as, am'') (s, l, r) ires
              else if s = ss + 2 * n + 15 then 
                  inv_after_left_moving (as, am'') (s, l, r) ires
              else False)"

declare fetch.simps[simp del]


lemma x_plus_helpers:
  "x + 4 = Suc (x + 3)"
  "x + 5 = Suc (x + 4)"
  "x + 6 = Suc (x + 5)"
  "x + 7 = Suc (x + 6)"
  "x + 8 = Suc (x + 7)"
  "x + 9 = Suc (x + 8)"
  "x + 10 = Suc (x + 9)"
  "x + 11 = Suc (x + 10)"
  "x + 12 = Suc (x + 11)"
  "x + 13 = Suc (x + 12)"
  "14 + x = Suc (x + 13)"
  "15 + x = Suc (x + 14)"
  "16 + x = Suc (x + 15)"
  by auto

lemma fetch_Dec[simp]: 
  "fetch (ci ly (start_of ly as) (Dec n e)) (Suc (2 * n)) Bk = (W1,  start_of ly as + 2 *n)"
  "fetch (ci ly (start_of ly as) (Dec n e)) (Suc (2 * n)) Oc = (R,  Suc (start_of ly as) + 2 *n)"
  "fetch (ci (ly) (start_of ly as) (Dec n e)) (Suc (Suc (2 * n))) Oc
     = (R, start_of ly as + 2*n + 2)"
  "fetch (ci (ly) (start_of ly as) (Dec n e)) (Suc (Suc (2 * n))) Bk
     = (L, start_of ly as + 2*n + 13)"
  "fetch (ci (ly) (start_of ly as) (Dec n e)) (Suc (Suc (Suc (2 * n)))) Oc
     = (R, start_of ly as + 2*n + 2)"
  "fetch (ci (ly) (start_of ly as) (Dec n e)) (Suc (Suc (Suc (2 * n)))) Bk
     = (L, start_of ly as + 2*n + 3)"
  "fetch (ci (ly) (start_of ly as) (Dec n e)) (2 * n + 4) Oc = (W0, start_of ly as + 2*n + 3)"
  "fetch (ci (ly) (start_of ly as) (Dec n e)) (2 * n + 4) Bk = (R, start_of ly as + 2*n + 4)"
  "fetch (ci (ly) (start_of ly as) (Dec n e)) (2 * n + 5) Bk = (R, start_of ly as + 2*n + 5)"
  "fetch (ci (ly) (start_of ly as) (Dec n e)) (2 * n + 6) Bk = (L, start_of ly as + 2*n + 6)"
  "fetch (ci (ly) (start_of ly as) (Dec n e)) (2 * n + 6) Oc = (L, start_of ly as + 2*n + 7)"
  "fetch (ci (ly) (start_of ly as) (Dec n e)) (2 * n + 7) Bk = (L, start_of ly as + 2*n + 10)"
  "fetch (ci (ly) (start_of ly as) (Dec n e)) (2 * n + 8) Bk = (W1, start_of ly as + 2*n + 7)"
  "fetch (ci (ly) (start_of ly as) (Dec n e)) (2 * n + 8) Oc = (R, start_of ly as + 2*n + 8)"
  "fetch (ci (ly) (start_of ly as) (Dec n e)) (2 * n + 9) Bk = (L, start_of ly as + 2*n + 9)"
  "fetch (ci (ly) (start_of ly as) (Dec n e)) (2 * n + 9) Oc = (R, start_of ly as + 2*n + 8)"
  "fetch (ci (ly) (start_of ly as) (Dec n e)) (2 * n + 10) Bk = (R, start_of ly as + 2*n + 4)"
  "fetch (ci (ly) (start_of ly as) (Dec n e)) (2 * n + 10) Oc = (W0, start_of ly as + 2*n + 9)"
  "fetch (ci (ly) (start_of ly as) (Dec n e)) (2 * n + 11) Oc = (L, start_of ly as + 2*n + 10)"
  "fetch (ci (ly) (start_of ly as) (Dec n e)) (2 * n + 11) Bk = (L, start_of ly as + 2*n + 11)"
  "fetch (ci (ly) (start_of ly as) (Dec n e)) (2 * n + 12) Oc = (L, start_of ly as + 2*n + 10)"
  "fetch (ci (ly) (start_of ly as) (Dec n e)) (2 * n + 12) Bk = (R, start_of ly as + 2*n + 12)"
  "fetch (ci (ly) (start_of ly as) (Dec n e)) (2 * n + 13) Bk = (R, start_of ly as + 2*n + 16)"
  "fetch (ci (ly) (start_of ly as) (Dec n e)) (14 + 2 * n) Oc = (L, start_of ly as + 2*n + 13)"
  "fetch (ci (ly) (start_of ly as) (Dec n e)) (14 + 2 * n) Bk = (L, start_of ly as + 2*n + 14)"
  "fetch (ci (ly) (start_of ly as) (Dec n e)) (15 + 2 * n) Oc = (L, start_of ly as + 2*n + 13)"
  "fetch (ci (ly) (start_of ly as) (Dec n e)) (15 + 2 * n) Bk = (R, start_of ly as + 2*n + 15)"
  "fetch (ci (ly) (start_of (ly) as) (Dec n e)) (16 + 2 * n) Bk = (R, start_of (ly) e)"
  unfolding x_plus_helpers fetch.simps
  by(auto simp: ci.simps shift.simps nth_append tdec_b_def length_findnth adjust.simps)

lemma steps_start_of_invb_inv_locate_a1[simp]: 
  "r = []  hd r = Bk; inv_locate_a (as, lm) (n, l, r) ires
     stp la ra.
  steps (start_of ly as + 2 * n, l, r) (ci ly (start_of ly as) (Dec n e), 
  start_of ly as - Suc 0) stp = (Suc (start_of ly as + 2 * n), la, ra) 
  inv_locate_b (as, lm) (n, la, ra) ires"
  apply(rule_tac x = "Suc (Suc 0)" in exI)
  apply(auto simp: steps.simps step.simps length_ci_dec)
  apply(cases r, simp_all)
  done

lemma steps_start_of_invb_inv_locate_a2[simp]: 
  "inv_locate_a (as, lm) (n, l, r) ires; r  []  hd r  Bk
     stp la ra.
  steps (start_of ly as + 2 * n, l, r) (ci ly (start_of ly as) (Dec n e), 
  start_of ly as - Suc 0) stp = (Suc (start_of ly as + 2 * n), la, ra) 
  inv_locate_b (as, lm) (n, la, ra) ires"
  apply(rule_tac x = "(Suc 0)" in exI, cases "hd r", simp_all)
  apply(auto simp: steps.simps step.simps length_ci_dec)
  apply(cases r, simp_all)
  done

fun abc_dec_1_stage1:: "config  nat  nat  nat"
  where
    "abc_dec_1_stage1 (s, l, r) ss n = 
       (if s > ss  s  ss + 2*n + 1 then 4
        else if s = ss + 2 * n + 13  s = ss + 2*n + 14 then 3
        else if s = ss + 2*n + 15 then 2
        else 0)"

fun abc_dec_1_stage2:: "config  nat  nat  nat"
  where
    "abc_dec_1_stage2 (s, l, r) ss n = 
       (if s  ss + 2 * n + 1 then (ss + 2 * n + 16 - s)
        else if s = ss + 2*n + 13 then length l
        else if s = ss + 2*n + 14 then length l
        else 0)"

fun abc_dec_1_stage3 :: "config  nat  nat  nat"
  where
    "abc_dec_1_stage3 (s, l, r) ss n  = 
        (if s  ss + 2*n + 1 then 
             if (s - ss) mod 2 = 0 then 
                         if r  []  hd r = Oc then 0 else 1  
                         else length r
         else if s = ss + 2 * n + 13 then 
             if r  []  hd r = Oc then 2 
             else 1
         else if s = ss + 2 * n + 14 then 
             if r  []  hd r = Oc then 3 else 0 
         else 0)"

fun abc_dec_1_measure :: "(config × nat × nat)  (nat × nat × nat)"
  where
    "abc_dec_1_measure (c, ss, n) = (abc_dec_1_stage1 c ss n, 
                   abc_dec_1_stage2 c ss n, abc_dec_1_stage3 c ss n)"

definition abc_dec_1_LE ::
  "((config × nat ×
  nat) × (config × nat × nat)) set"
  where "abc_dec_1_LE  (inv_image lex_triple abc_dec_1_measure)"

lemma wf_dec_le: "wf abc_dec_1_LE"
  by(auto intro:wf_inv_image simp:abc_dec_1_LE_def lex_triple_def lex_pair_def)

lemma startof_Suc2:
  "abc_fetch as ap = Some (Dec n e)  
        start_of (layout_of ap) (Suc as) = 
            start_of (layout_of ap) as + 2 * n + 16"
  apply(auto simp: start_of.simps layout_of.simps  
      length_of.simps abc_fetch.simps 
      take_Suc_conv_app_nth split: if_splits)
  done

lemma start_of_less_2: 
  "start_of ly e  start_of ly (Suc e)"
  apply(cases "e < length ly")
   apply(auto simp: start_of.simps take_Suc take_Suc_conv_app_nth)
  done

lemma start_of_less_1: "start_of ly e  start_of ly (e + d)"
proof(induct d)
  case 0 thus "?case" by simp
next
  case (Suc d)
  have "start_of ly e  start_of ly (e + d)"  by fact
  moreover have "start_of ly (e + d)  start_of ly (Suc (e + d))"
    by(rule_tac start_of_less_2)
  ultimately show"?case"
    by(simp)
qed

lemma start_of_less: 
  assumes "e < as"
  shows "start_of ly e  start_of ly as"
proof -
  obtain d where " as = e + d"
    using assms by (metis less_imp_add_positive)
  thus "?thesis"
    by(simp add: start_of_less_1)
qed

lemma start_of_ge: 
  assumes fetch: "abc_fetch as ap = Some (Dec n e)"
    and layout: "ly = layout_of ap"
    and great: "e > as"
  shows "start_of ly e  start_of ly as + 2*n + 16"
proof(cases "e = Suc as")
  case True
  have "e = Suc as" by fact
  moreover hence "start_of ly (Suc as) = start_of ly as + 2*n + 16"
    using layout fetch
    by(simp add: startof_Suc2)
  ultimately show "?thesis" by (simp)
next
  case False
  have "e  Suc as" by fact
  then have "e > Suc as" using great by arith
  then have "start_of ly (Suc as)  start_of ly e"
    by(simp add: start_of_less)
  moreover have "start_of ly (Suc as) = start_of ly as + 2*n + 16"
    using layout fetch
    by(simp add: startof_Suc2)
  ultimately show "?thesis"
    by arith
qed

declare dec_inv_1.simps[simp del]

lemma start_of_ineq1[simp]: 
  "abc_fetch as aprog = Some (Dec n e); ly = layout_of aprog
    (start_of ly e  Suc (start_of ly as + 2 * n) 
        start_of ly e  Suc (Suc (start_of ly as + 2 * n))   
        start_of ly e  start_of ly as + 2 * n + 3  
        start_of ly e  start_of ly as + 2 * n + 4 
        start_of ly e  start_of ly as + 2 * n + 5  
        start_of ly e  start_of ly as + 2 * n + 6  
        start_of ly e  start_of ly as + 2 * n + 7 
        start_of ly e  start_of ly as + 2 * n + 8  
        start_of ly e  start_of ly as + 2 * n + 9  
        start_of ly e  start_of ly as + 2 * n + 10 
        start_of ly e  start_of ly as + 2 * n + 11  
        start_of ly e  start_of ly as + 2 * n + 12  
        start_of ly e  start_of ly as + 2 * n + 13 
        start_of ly e  start_of ly as + 2 * n + 14  
        start_of ly e  start_of ly as + 2 * n + 15)"
  using start_of_ge[of as aprog n e ly] start_of_less[of e as ly]
  apply(cases "e < as", simp)
  apply(cases "e = as", simp, simp)
  done

lemma start_of_ineq2[simp]: "abc_fetch as aprog = Some (Dec n e); ly = layout_of aprog
       (Suc (start_of ly as + 2 * n)  start_of ly e 
          Suc (Suc (start_of ly as + 2 * n))  start_of ly e  
          start_of ly as + 2 * n + 3  start_of ly e  
          start_of ly as + 2 * n + 4  start_of ly e 
          start_of ly as + 2 * n + 5 start_of ly e  
          start_of ly as + 2 * n + 6  start_of ly e 
          start_of ly as + 2 * n + 7  start_of ly e  
          start_of ly as + 2 * n + 8  start_of ly e  
          start_of ly as + 2 * n + 9  start_of ly e  
          start_of ly as + 2 * n + 10  start_of ly e 
          start_of ly as + 2 * n + 11  start_of ly e  
          start_of ly as + 2 * n + 12  start_of ly e  
          start_of ly as + 2 * n + 13  start_of ly e  
          start_of ly as + 2 * n + 14  start_of ly e  
          start_of ly as + 2 * n + 15  start_of ly e)"
  using start_of_ge[of as aprog n e ly] start_of_less[of e as ly]
  apply(cases "e < as", simp, simp)
  apply(cases "e = as", simp, simp)
  done

lemma inv_locate_b_nonempty[simp]: "inv_locate_b (as, lm) (n, [], []) ires = False"
  apply(auto simp: inv_locate_b.simps in_middle.simps split: if_splits)
  done

lemma inv_locate_b_no_Bk[simp]: "inv_locate_b (as, lm) (n, [], Bk # list) ires = False"
  apply(auto simp: inv_locate_b.simps in_middle.simps split: if_splits)
  done

lemma dec_first_on_right_moving_Oc[simp]: 
  "dec_first_on_right_moving n (as, am) (s, aaa, Oc # xs) ires
    dec_first_on_right_moving n (as, am) (s', Oc # aaa, xs) ires"
  apply(simp only: dec_first_on_right_moving.simps)
  apply(erule exE)+
  apply(rename_tac lm1 lm2 m ml mr rn)
  apply(rule_tac x = lm1 in exI, rule_tac x = lm2 in exI, 
      rule_tac x = m in exI, rule_tac x = "Suc ml" in exI, 
      rule_tac x = "mr - 1" in exI)
  apply(case_tac [!] mr, auto)
  done

lemma dec_first_on_right_moving_Bk_nonempty[simp]: 
  "dec_first_on_right_moving n (as, am) (s, l, Bk # xs) ires  l  []"
  apply(auto simp: dec_first_on_right_moving.simps split: if_splits)
  done

lemma replicateE: 
  "¬ length lm1 < length am; 
    am @ replicate (length lm1 - length am) 0 @ [0::nat] = 
                                                lm1 @ m # lm2;
    0 < m
    RR"
  apply(subgoal_tac "lm2 = []", simp)
  apply(drule_tac length_equal, simp)
  done

lemma dec_after_clear_Bk_strip_hd[simp]: 
  "dec_first_on_right_moving n (as, 
                   abc_lm_s am n (abc_lm_v am n)) (s, l, Bk # xs) ires
 dec_after_clear (as, abc_lm_s am n 
                 (abc_lm_v am n - Suc 0)) (s', tl l, hd l # Bk # xs) ires"
  apply(simp only: dec_first_on_right_moving.simps 
      dec_after_clear.simps abc_lm_s.simps abc_lm_v.simps)
  apply(erule_tac exE)+
  apply(rename_tac lm1 lm2 m ml mr rn)
  apply(cases "n < length am")
  by(rule_tac x = lm1 in exI, rule_tac x = lm2 in exI, 
      rule_tac x = "m - 1" in exI, auto elim:replicateE)

lemma dec_first_on_right_moving_dec_after_clear_cases[simp]: 
  "dec_first_on_right_moving n (as, 
                   abc_lm_s am n (abc_lm_v am n)) (s, l, []) ires
 (l = []  dec_after_clear (as, 
             abc_lm_s am n (abc_lm_v am n - Suc 0)) (s', [], [Bk]) ires) 
    (l  []  dec_after_clear (as, abc_lm_s am n 
                      (abc_lm_v am n - Suc 0)) (s', tl l, [hd l]) ires)"
  apply(subgoal_tac "l  []", 
      simp only: dec_first_on_right_moving.simps 
      dec_after_clear.simps abc_lm_s.simps abc_lm_v.simps)
   apply(erule_tac exE)+
   apply(rename_tac lm1 lm2 m ml mr rn)
   apply(cases "n < length am", simp)
    apply(rule_tac x = lm1 in exI, rule_tac x = "m - 1" in exI, auto)
    apply(case_tac [1-2] m, auto)
  apply(auto simp: dec_first_on_right_moving.simps split: if_splits)
  done

lemma dec_after_clear_Bk_via_Oc[simp]: "dec_after_clear (as, am) (s, l, Oc # r) ires
                 dec_after_clear (as, am) (s', l, Bk # r) ires"
  apply(auto simp: dec_after_clear.simps)
  done

lemma dec_right_move_Bk_via_clear_Bk[simp]: "dec_after_clear (as, am) (s, l, Bk # r) ires
                 dec_right_move (as, am) (s', Bk # l, r) ires"
  apply(auto simp: dec_after_clear.simps dec_right_move.simps split: if_splits)
  done

lemma dec_right_move_Bk_Bk_via_clear[simp]: "dec_after_clear (as, am) (s, l, []) ires
              dec_right_move (as, am) (s', Bk # l, [Bk]) ires"
  apply(auto simp: dec_after_clear.simps dec_right_move.simps split: if_splits)
  done

lemma dec_right_move_no_Oc[simp]:"dec_right_move (as, am) (s, l, Oc # r) ires = False"
  apply(auto simp: dec_right_move.simps)
  done

lemma dec_right_move_2_check_right_move[simp]:
  "dec_right_move (as, am) (s, l, Bk # r) ires
       dec_check_right_move (as, am) (s', Bk # l, r) ires"
  apply(auto simp: dec_right_move.simps dec_check_right_move.simps split: if_splits)
  done

lemma lm_iff_empty[simp]: "(<lm::nat list> = []) = (lm = [])"
  apply(cases lm, simp_all add: tape_of_nl_cons)
  done

lemma dec_right_move_asif_Bk_singleton[simp]: 
  "dec_right_move (as, am) (s, l, []) ires= 
  dec_right_move (as, am) (s, l, [Bk]) ires"
  apply(simp add: dec_right_move.simps)
  done

lemma dec_check_right_move_nonempty[simp]: "dec_check_right_move (as, am) (s, l, r) ires l  []"
  apply(auto simp: dec_check_right_move.simps split: if_splits)
  done

lemma dec_check_right_move_Oc_tail[simp]: "dec_check_right_move (as, am) (s, l, Oc # r) ires
              dec_after_write (as, am) (s', tl l, hd l # Oc # r) ires"
  apply(auto simp: dec_check_right_move.simps dec_after_write.simps)
  apply(rename_tac lm1 lm2 m rn)
  apply(rule_tac x = lm1 in exI, rule_tac x = lm2 in exI, rule_tac x = m in exI, auto)
  done

lemma dec_left_move_Bk_tail[simp]: "dec_check_right_move (as, am) (s, l, Bk # r) ires
                 dec_left_move (as, am) (s', tl l, hd l # Bk # r) ires"
  apply(auto simp: dec_check_right_move.simps dec_left_move.simps inv_after_move.simps)
  apply(rename_tac lm1 lm2 m rn)
  apply(rule_tac x = lm1 in exI, rule_tac x = m in exI, auto split: if_splits)
     apply(case_tac [!] lm2, simp_all add: tape_of_nl_cons split: if_splits)
   apply(rule_tac [!] x = "(Suc rn)" in exI, simp_all)
  done

lemma dec_left_move_tail[simp]: "dec_check_right_move (as, am) (s, l, []) ires
              dec_left_move (as, am) (s', tl l, [hd l]) ires"
  apply(auto simp: dec_check_right_move.simps dec_left_move.simps inv_after_move.simps)
  apply(rename_tac lm1 m)
  apply(rule_tac x = lm1 in exI, rule_tac x = m in exI, auto)
  done

lemma dec_left_move_no_Oc[simp]: "dec_left_move (as, am) (s, aaa, Oc # xs) ires = False"
  apply(auto simp: dec_left_move.simps inv_after_move.simps)
  done

lemma dec_left_move_nonempty[simp]: "dec_left_move (as, am) (s, l, r) ires
              l  []"
  apply(auto simp: dec_left_move.simps split: if_splits)
  done

lemma inv_on_left_moving_in_middle_B_Oc_Bk_Bks[simp]: "inv_on_left_moving_in_middle_B (as, [m])
  (s', Oc # Ocm @ Bk # Bk # ires, Bk # Bkrn) ires"
  apply(simp add: inv_on_left_moving_in_middle_B.simps)
  apply(rule_tac x = "[m]" in exI, auto)
  done


lemma inv_on_left_moving_in_middle_B_Oc_Bk_Bks_rev[simp]: "lm1  []  
  inv_on_left_moving_in_middle_B (as, lm1 @ [m]) (s', 
  Oc # Ocm @ Bk # <rev lm1> @ Bk # Bk # ires, Bk # Bkrn) ires"
  apply(simp only: inv_on_left_moving_in_middle_B.simps)
  apply(rule_tac x = "lm1 @ [m ]" in exI, rule_tac x = "[]" in exI, simp)
  apply(simp add: tape_of_nl_cons split: if_splits)
  done

lemma inv_on_left_moving_Bk_tail[simp]: "dec_left_move (as, am) (s, l, Bk # r) ires
        inv_on_left_moving (as, am) (s', tl l, hd l # Bk # r) ires"
  apply(auto simp: dec_left_move.simps inv_on_left_moving.simps split: if_splits)
  done

lemma inv_on_left_moving_tail[simp]: "dec_left_move (as, am) (s, l, []) ires
              inv_on_left_moving (as, am) (s', tl l, [hd l]) ires"
  apply(auto simp: dec_left_move.simps inv_on_left_moving.simps split: if_splits)
  done

lemma dec_on_right_moving_Oc_mv[simp]: "dec_after_write (as, am) (s, l, Oc # r) ires
        dec_on_right_moving (as, am) (s', Oc # l, r) ires"
  apply(auto simp: dec_after_write.simps dec_on_right_moving.simps)
  apply(rename_tac lm1 lm2 m rn)
  apply(rule_tac x = "lm1 @ [m]" in exI, rule_tac x = "tl lm2" in exI, 
      rule_tac x = "hd lm2" in exI, simp)
  apply(rule_tac x = "Suc 0" in exI,rule_tac x =  "Suc (hd lm2)" in exI)
  apply(case_tac lm2, auto split: if_splits simp: tape_of_nl_cons)
  done

lemma dec_after_write_Oc_via_Bk[simp]: "dec_after_write (as, am) (s, l, Bk # r) ires
        dec_after_write (as, am) (s', l, Oc # r) ires"
  apply(auto simp: dec_after_write.simps)
  done

lemma dec_after_write_Oc_empty[simp]: "dec_after_write (as, am) (s, aaa, []) ires
              dec_after_write (as, am) (s', aaa, [Oc]) ires"
  apply(auto simp: dec_after_write.simps)
  done

lemma dec_on_right_moving_Oc_move[simp]: "dec_on_right_moving (as, am) (s, l, Oc # r) ires
        dec_on_right_moving (as, am) (s', Oc # l, r) ires"
  apply(simp only: dec_on_right_moving.simps)
  apply(erule_tac exE)+
  apply(rename_tac lm1 lm2 m ml mr rn)
  apply(erule conjE)+
  apply(rule_tac x = lm1 in exI, rule_tac x = lm2 in exI,
      rule_tac x = "m" in exI, rule_tac x = "Suc ml" in exI, 
      rule_tac x = "mr - 1" in exI, simp)
  apply(case_tac mr, auto)
  done

lemma dec_on_right_moving_nonempty[simp]: "dec_on_right_moving (as, am) (s, l, r) ires  l  []"
  apply(auto simp: dec_on_right_moving.simps split: if_splits)
  done

lemma dec_after_clear_Bk_tail[simp]: "dec_on_right_moving (as, am) (s, l, Bk # r) ires
        dec_after_clear (as, am) (s', tl l, hd l # Bk # r) ires"
  apply(auto simp: dec_on_right_moving.simps dec_after_clear.simps simp del:split_head_repeat)
  apply(rename_tac lm1 lm2 m ml mr rn)
  apply(case_tac mr, auto split: if_splits)
  done

lemma dec_after_clear_tail[simp]: "dec_on_right_moving (as, am) (s, l, []) ires
              dec_after_clear (as, am) (s', tl l, [hd l]) ires"
  apply(auto simp: dec_on_right_moving.simps dec_after_clear.simps)
  apply(simp_all split: if_splits)
  apply(rule_tac x = lm1 in exI, simp)
  done

lemma dec_false_1[simp]:
  "abc_lm_v am n = 0; inv_locate_b (as, am) (n, aaa, Oc # xs) ires
   False"
  apply(auto simp: inv_locate_b.simps in_middle.simps)
   apply(rename_tac lm1 lm2 m ml Mr rn)
   apply(case_tac "length lm1  length am", auto)
    apply(subgoal_tac "lm2 = []", simp, subgoal_tac "m = 0", simp)
      apply(case_tac Mr, auto simp: )
     apply(subgoal_tac "Suc (length lm1) - length am = 
                   Suc (length lm1 - length am)", 
      simp add: exp_ind del: replicate.simps, simp)
    apply(drule_tac xs = "am @ replicate (Suc (length lm1) - length am) 0"
      and ys = "lm1 @ m # lm2" in length_equal, simp)
   apply(case_tac Mr, auto simp: abc_lm_v.simps)
  apply(rename_tac lm1 m ml Mr)
  apply(case_tac "Mr = 0", simp_all split: if_splits)
  apply(subgoal_tac "Suc (length lm1) - length am = 
                       Suc (length lm1 - length am)", 
      simp add: exp_ind del: replicate.simps, simp)
  done

lemma inv_on_left_moving_Bk_tl[simp]: 
  "inv_locate_b (as, am) (n, aaa, Bk # xs) ires; 
   abc_lm_v am n = 0
    inv_on_left_moving (as, abc_lm_s am n 0) 
                         (s, tl aaa, hd aaa # Bk # xs) ires"
  apply(simp add: inv_on_left_moving.simps)
  apply(simp only: inv_locate_b.simps in_middle.simps) 
  apply(erule_tac exE)+
  apply(rename_tac Lm1 Lm2 tn M ml Mr rn)
  apply(subgoal_tac "¬ inv_on_left_moving_in_middle_B 
         (as, abc_lm_s am n 0) (s, tl aaa, hd aaa # Bk # xs) ires", simp)
   apply(simp only: inv_on_left_moving_norm.simps)
   apply(erule_tac conjE)+
   apply(rule_tac x = Lm1 in exI, rule_tac x = Lm2 in exI, 
      rule_tac x =  M in exI, rule_tac x = M in exI, 
      rule_tac x = "Suc 0" in exI, simp add: abc_lm_s.simps)
   apply(case_tac Mr, auto simp: abc_lm_v.simps)
   apply(simp only: exp_ind[THEN sym] replicate_Suc Nat.Suc_diff_le)
  apply(auto simp: inv_on_left_moving_in_middle_B.simps split: if_splits)
  done


lemma inv_on_left_moving_tl[simp]:
  "abc_lm_v am n = 0; inv_locate_b (as, am) (n, aaa, []) ires
    inv_on_left_moving (as, abc_lm_s am n 0) (s, tl aaa, [hd aaa]) ires"
  supply [[simproc del: defined_all]]
  apply(simp add: inv_on_left_moving.simps)
  apply(simp only: inv_locate_b.simps in_middle.simps) 
  apply(erule_tac exE)+
  apply(rename_tac Lm1 Lm2 tn M ml Mr rn)
  apply(simp add: inv_on_left_moving.simps)
  apply(subgoal_tac "¬ inv_on_left_moving_in_middle_B 
         (as, abc_lm_s am n 0) (s, tl aaa, [hd aaa]) ires", simp)
   apply(simp only: inv_on_left_moving_norm.simps)
   apply(erule_tac conjE)+
   apply(rule_tac x = Lm1 in exI, rule_tac x = Lm2 in exI, 
      rule_tac x =  M in exI, rule_tac x = M in exI, 
      rule_tac x = "Suc 0" in exI, simp add: abc_lm_s.simps)
   apply(case_tac Mr, simp_all, auto simp: abc_lm_v.simps)
    apply(simp_all only: exp_ind Nat.Suc_diff_le del: replicate_Suc, simp_all)
  apply(auto simp: inv_on_left_moving_in_middle_B.simps split: if_splits)
   apply(case_tac [!] M, simp_all)
  done

declare dec_inv_1.simps[simp del]

declare inv_locate_n_b.simps [simp del]

lemma dec_first_on_right_moving_Oc_via_inv_locate_n_b[simp]:
  "inv_locate_n_b (as, am) (n, aaa, Oc # xs) ires
  dec_first_on_right_moving n (as, abc_lm_s am n (abc_lm_v am n))  
                                      (s, Oc # aaa, xs) ires"
  apply(auto simp: inv_locate_n_b.simps dec_first_on_right_moving.simps 
      abc_lm_s.simps abc_lm_v.simps)
     apply(rename_tac Lm1 Lm2 m rn)
     apply(rule_tac x = Lm1 in exI, rule_tac x = Lm2 in exI, 
      rule_tac x = m in exI, simp)
     apply(rule_tac x = "Suc (Suc 0)" in exI, 
      rule_tac x = "m - 1" in exI, simp)
     apply (metis One_nat_def Suc_pred cell.distinct(1) empty_replicate list.inject list.sel(3)
      neq0_conv self_append_conv2 tl_append2 tl_replicate)
    apply(rename_tac Lm1 Lm2 m rn)
    apply(rule_tac x = Lm1 in exI, rule_tac x = Lm2 in exI, 
      rule_tac x = m in exI, 
      simp add: Suc_diff_le exp_ind del: replicate.simps)
    apply(rule_tac x = "Suc (Suc 0)" in exI, 
      rule_tac x = "m - 1" in exI, simp)
    apply (metis cell.distinct(1) empty_replicate gr_zeroI list.inject replicateE self_append_conv2)
   apply(rename_tac Lm1 m)
   apply(rule_tac x = Lm1 in exI, rule_tac x = "[]" in exI, 
      rule_tac x = m in exI, simp)
   apply(rule_tac x = "Suc (Suc 0)" in exI, 
      rule_tac x = "m - 1" in exI, simp)
   apply(case_tac m, auto)
  apply(rename_tac Lm1 m)
  apply(rule_tac x = Lm1 in exI, rule_tac x = "[]" in exI, rule_tac x = m in exI, 
      simp add: Suc_diff_le exp_ind del: replicate.simps, simp)
  done

lemma inv_on_left_moving_nonempty[simp]: "inv_on_left_moving (as, am) (s, [], r) ires 
  = False"
  apply(simp add: inv_on_left_moving.simps inv_on_left_moving_norm.simps
      inv_on_left_moving_in_middle_B.simps)
  done

lemma inv_check_left_moving_startof_nonempty[simp]: 
  "inv_check_left_moving (as, abc_lm_s am n 0)
  (start_of (layout_of aprog) as + 2 * n + 14, [], Oc # xs) ires
 = False"
  apply(simp add: inv_check_left_moving.simps inv_check_left_moving_in_middle.simps)
  done

lemma start_of_lessE[elim]: "abc_fetch as ap = Some (Dec n e);
                start_of (layout_of ap) as < start_of (layout_of ap) e; 
                start_of (layout_of ap) e  Suc (start_of (layout_of ap) as + 2 * n)
        RR"
  using start_of_less[of e as "layout_of ap"] start_of_ge[of as ap n e "layout_of ap"]
  apply(cases "as < e", simp)
  apply(cases "as = e", simp, simp)
  done

lemma crsp_step_dec_b_e_pre':
  assumes layout: "ly = layout_of ap"
    and inv_start: "inv_locate_b (as, lm) (n, la, ra) ires"
    and fetch: "abc_fetch as ap = Some (Dec n e)"
    and dec_0: "abc_lm_v lm n = 0"
    and f: "f = (λ stp. (steps (Suc (start_of ly as) + 2 * n, la, ra) (ci ly (start_of ly as) (Dec n e), 
            start_of ly as - Suc 0) stp, start_of ly as, n))"
    and P: "P = (λ ((s, l, r), ss, x). s = start_of ly e)"
    and Q: "Q = (λ ((s, l, r), ss, x). dec_inv_1 ly x e (as, lm) (s, l, r) ires)"
  shows " stp. P (f stp)  Q (f stp)"
proof(rule_tac LE = abc_dec_1_LE in halt_lemma2)
  show "wf abc_dec_1_LE" by(intro wf_dec_le)
next
  show "Q (f 0)"
    using layout fetch
    apply(simp add: f steps.simps Q dec_inv_1.simps)
    apply(subgoal_tac "e > as  e = as  e < as")
     apply(auto simp: inv_start)
    done
next
  show "¬ P (f 0)"
    using layout fetch
    apply(simp add: f steps.simps P)
    done
next
  show "n. ¬ P (f n)  Q (f n)  Q (f (Suc n))  (f (Suc n), f n)  abc_dec_1_LE"
    using fetch
  proof(rule_tac allI, rule_tac impI)
    fix na
    assume "¬ P (f na)  Q (f na)"
    thus "Q (f (Suc na))  (f (Suc na), f na)  abc_dec_1_LE"
      apply(simp add: f)
      apply(cases "steps (Suc (start_of ly as + 2 * n), la, ra)
        (ci ly (start_of ly as) (Dec n e), start_of ly as - Suc 0) na", simp)
    proof -
      fix a b c 
      assume "¬ P ((a, b, c), start_of ly as, n)  Q ((a, b, c), start_of ly as, n)"
      thus "Q (step (a, b, c) (ci ly (start_of ly as) (Dec n e), start_of ly as - Suc 0), start_of ly as, n) 
               ((step (a, b, c) (ci ly (start_of ly as) (Dec n e), start_of ly as - Suc 0), start_of ly as, n), 
                   (a, b, c), start_of ly as, n)  abc_dec_1_LE"
        apply(simp add: Q)
        apply(cases c;cases "hd c")
           apply(simp_all add: dec_inv_1.simps Let_def split: if_splits)
        using fetch layout dec_0
                        apply(auto simp: step.simps P dec_inv_1.simps Let_def abc_dec_1_LE_def
            lex_triple_def lex_pair_def)
        using dec_0
        apply(drule_tac dec_false_1, simp_all)
        done
    qed
  qed
qed

lemma crsp_step_dec_b_e_pre:
  assumes "ly = layout_of ap"
    and inv_start: "inv_locate_b (as, lm) (n, la, ra) ires"
    and dec_0: "abc_lm_v lm n  = 0"
    and fetch: "abc_fetch as ap = Some (Dec n e)"
  shows "stp lb rb.
       steps (Suc (start_of ly as) + 2 * n, la, ra) (ci ly (start_of ly as) (Dec n e), 
       start_of ly as - Suc 0) stp = (start_of ly e, lb, rb) 
       dec_inv_1 ly n e (as, lm) (start_of ly e, lb, rb) ires"
  using assms
  apply(drule_tac crsp_step_dec_b_e_pre', auto)
  apply(rename_tac stp a b)
  apply(rule_tac x = stp in exI, simp)
  done

lemma crsp_abc_step_via_stop[simp]:
  "abc_lm_v lm n = 0;
  inv_stop (as, abc_lm_s lm n (abc_lm_v lm n)) (start_of ly e, lb, rb) ires
   crsp ly (abc_step_l (as, lm) (Some (Dec n e))) (start_of ly e, lb, rb) ires"
  apply(auto simp: crsp.simps abc_step_l.simps inv_stop.simps)
  done

lemma crsp_step_dec_b_e:
  assumes layout: "ly = layout_of ap"
    and inv_start: "inv_locate_a (as, lm) (n, l, r) ires"
    and dec_0: "abc_lm_v lm n = 0"
    and fetch: "abc_fetch as ap = Some (Dec n e)"
  shows "stp > 0. crsp ly (abc_step_l (as, lm) (Some (Dec n e)))
  (steps (start_of ly as + 2 * n, l, r) (ci ly (start_of ly as) (Dec n e), start_of ly as - Suc 0) stp) ires"
proof -
  let ?P = "ci ly (start_of ly as) (Dec n e)"
  let ?off = "start_of ly as - Suc 0"
  have " stp la ra. steps (start_of ly as + 2 * n, l, r) (?P, ?off) stp = (Suc (start_of ly as) + 2*n, la, ra)
               inv_locate_b (as, lm) (n, la, ra) ires"
    using inv_start
    apply(cases "r = []  hd r = Bk", simp_all)
    done
  from this obtain stpa la ra where a:
    "steps (start_of ly as + 2 * n, l, r) (?P, ?off) stpa = (Suc (start_of ly as) + 2*n, la, ra)
               inv_locate_b (as, lm) (n, la, ra) ires" by blast
  have " stp lb rb. steps (Suc (start_of ly as) + 2 * n, la, ra) (?P, ?off) stp = (start_of ly e, lb, rb)
               dec_inv_1 ly n e (as, lm) (start_of ly e, lb, rb) ires"
    using assms a
    apply(rule_tac crsp_step_dec_b_e_pre, auto)
    done
  from this obtain stpb lb rb where b:
    "steps (Suc (start_of ly as) + 2 * n, la, ra) (?P, ?off) stpb = (start_of ly e, lb, rb)
               dec_inv_1 ly n e (as, lm) (start_of ly e, lb, rb) ires"  by blast
  from a b show "stp > 0. crsp ly (abc_step_l (as, lm) (Some (Dec n e))) 
    (steps (start_of ly as + 2 * n, l, r) (?P, ?off) stp) ires"
    apply(rule_tac x = "stpa + stpb" in exI)
    using dec_0
    apply(simp add: dec_inv_1.simps )
    apply(cases stpa, simp_all add: steps.simps)
    done
qed    

fun dec_inv_2 :: "layout  nat  nat  dec_inv_t"
  where
    "dec_inv_2 ly n e (as, am) (s, l, r) ires =
           (let ss = start_of ly as in
            let am' = abc_lm_s am n (abc_lm_v am n - Suc 0) in
            let am'' = abc_lm_s am n (abc_lm_v am n) in
              if s = 0 then False
              else if s = ss + 2 * n then 
                      inv_locate_a (as, am) (n, l, r) ires
              else if s = ss + 2 * n + 1 then 
                      inv_locate_n_b (as, am) (n, l, r) ires
              else if s = ss + 2 * n + 2 then 
                      dec_first_on_right_moving n (as, am'') (s, l, r) ires
              else if s = ss + 2 * n + 3 then 
                      dec_after_clear (as, am') (s, l, r) ires
              else if s = ss + 2 * n + 4 then 
                      dec_right_move (as, am') (s, l, r) ires
              else if s = ss + 2 * n + 5 then 
                      dec_check_right_move (as, am') (s, l, r) ires
              else if s = ss + 2 * n + 6 then 
                      dec_left_move (as, am') (s, l, r) ires
              else if s = ss + 2 * n + 7 then 
                      dec_after_write (as, am') (s, l, r) ires
              else if s = ss + 2 * n + 8 then 
                      dec_on_right_moving (as, am') (s, l, r) ires
              else if s = ss + 2 * n + 9 then 
                      dec_after_clear (as, am') (s, l, r) ires
              else if s = ss + 2 * n + 10 then 
                      inv_on_left_moving (as, am') (s, l, r) ires
              else if s = ss + 2 * n + 11 then 
                      inv_check_left_moving (as, am') (s, l, r) ires
              else if s = ss + 2 * n + 12 then 
                      inv_after_left_moving (as, am') (s, l, r) ires
              else if s = ss + 2 * n + 16 then 
                      inv_stop (as, am') (s, l, r) ires
              else False)"

declare dec_inv_2.simps[simp del]
fun abc_dec_2_stage1 :: "config  nat  nat  nat"
  where
    "abc_dec_2_stage1 (s, l, r) ss n = 
              (if s  ss + 2*n + 1 then 7
               else if s = ss + 2*n + 2 then 6 
               else if s = ss + 2*n + 3 then 5
               else if s  ss + 2*n + 4  s  ss + 2*n + 9 then 4
               else if s = ss + 2*n + 6 then 3
               else if s = ss + 2*n + 10  s = ss + 2*n + 11 then 2
               else if s = ss + 2*n + 12 then 1
               else 0)"

fun abc_dec_2_stage2 :: "config  nat  nat  nat"
  where
    "abc_dec_2_stage2 (s, l, r) ss n = 
       (if s  ss + 2 * n + 1 then (ss + 2 * n + 16 - s)
        else if s = ss + 2*n + 10 then length l
        else if s = ss + 2*n + 11 then length l
        else if s = ss + 2*n + 4 then length r - 1
        else if s = ss + 2*n + 5 then length r 
        else if s = ss + 2*n + 7 then length r - 1
        else if s = ss + 2*n + 8 then  
              length r + length (takeWhile (λ a. a = Oc) l) - 1
        else if s = ss + 2*n + 9 then 
              length r + length (takeWhile (λ a. a = Oc) l) - 1
        else 0)"

fun abc_dec_2_stage3 :: "config  nat  nat  nat"
  where
    "abc_dec_2_stage3 (s, l, r) ss n  =
        (if s  ss + 2*n + 1 then 
            if (s - ss) mod 2 = 0 then if r  []  
                                          hd r = Oc then 0 else 1  
            else length r
         else if s = ss + 2 * n + 10 then 
             if  r  []  hd r = Oc then 2
             else 1
         else if s = ss + 2 * n + 11 then 
             if r  []  hd r = Oc then 3 
             else 0 
         else (ss + 2 * n + 16 - s))"

fun abc_dec_2_stage4 :: "config  nat  nat  nat"
  where
    "abc_dec_2_stage4 (s, l, r) ss n = 
          (if s = ss + 2*n + 2 then length r
           else if s = ss + 2*n + 8 then length r
           else if s = ss + 2*n + 3 then 
               if r  []  hd r = Oc then 1
               else 0
           else if s = ss + 2*n + 7 then 
               if r  []  hd r = Oc then 0 
               else 1
           else if s = ss + 2*n + 9 then 
               if r  []  hd r = Oc then 1
               else 0 
           else 0)"

fun abc_dec_2_measure :: "(config × nat × nat)  (nat × nat × nat × nat)"
  where
    "abc_dec_2_measure (c, ss, n) = 
  (abc_dec_2_stage1 c ss n, 
  abc_dec_2_stage2 c ss n, abc_dec_2_stage3 c ss n,  abc_dec_2_stage4 c ss n)"

definition lex_square:: 
  "((nat × nat × nat × nat) × (nat × nat × nat × nat)) set"
  where "lex_square  less_than <*lex*> lex_triple"

definition abc_dec_2_LE ::
  "((config × nat ×
  nat) × (config × nat × nat)) set"
  where "abc_dec_2_LE  (inv_image lex_square abc_dec_2_measure)"

lemma wf_dec2_le: "wf abc_dec_2_LE"
  by(auto simp:abc_dec_2_LE_def lex_square_def lex_triple_def lex_pair_def)

lemma fix_add: "fetch ap ((x::nat) + 2*n) b = fetch ap (2*n + x) b"
  using Suc_1 add.commute by metis

lemma inv_locate_n_b_Bk_elim[elim]: 
  "0 < abc_lm_v am n; inv_locate_n_b (as, am) (n, aaa, Bk # xs) ires 
  RR"
  by(auto simp:gr0_conv_Suc inv_locate_n_b.simps abc_lm_v.simps split: if_splits)

lemma inv_locate_n_b_nonemptyE[elim]:
  "0 < abc_lm_v am n; inv_locate_n_b (as, am) 
                                (n, aaa, []) ires  RR"
  apply(auto simp: inv_locate_n_b.simps abc_lm_v.simps split: if_splits)
  done

lemma no_Ocs_dec_after_write[simp]: "dec_after_write (as, am) (s, aa, r) ires
            takeWhile (λa. a = Oc) aa = []"
  apply(simp only : dec_after_write.simps)
  apply(erule exE)+
  apply(erule_tac conjE)+
  apply(cases aa, simp)
  apply(cases "hd aa", simp only: takeWhile.simps , simp_all split: if_splits)
  done

lemma fewer_Ocs_dec_on_right_moving[simp]: 
  "dec_on_right_moving (as, lm) (s, aa, []) ires; 
       length (takeWhile (λa. a = Oc) (tl aa)) 
            length (takeWhile (λa. a = Oc) aa) - Suc 0
     length (takeWhile (λa. a = Oc) (tl aa)) < 
                       length (takeWhile (λa. a = Oc) aa) - Suc 0"
  apply(simp only: dec_on_right_moving.simps)
  apply(erule_tac exE)+
  apply(erule_tac conjE)+
  apply(rename_tac lm1 lm2 m ml Mr rn)
  apply(case_tac Mr, auto split: if_splits)
  done

lemma more_Ocs_dec_after_clear[simp]: 
  "dec_after_clear (as, abc_lm_s am n (abc_lm_v am n - Suc 0)) 
             (start_of (layout_of aprog) as + 2 * n + 9, aa, Bk # xs) ires
  length xs - Suc 0 < length xs + 
                             length (takeWhile (λa. a = Oc) aa)"
  apply(simp only: dec_after_clear.simps)
  apply(erule_tac exE)+
  apply(erule conjE)+
  apply(simp split: if_splits )
  done

lemma more_Ocs_dec_after_clear2[simp]: 
  "dec_after_clear (as, abc_lm_s am n (abc_lm_v am n - Suc 0))
       (start_of (layout_of aprog) as + 2 * n + 9, aa, []) ires
     Suc 0 < length (takeWhile (λa. a = Oc) aa)"
  apply(simp add: dec_after_clear.simps split: if_splits)
  done

lemma inv_check_left_moving_nonemptyE[elim]: 
  "inv_check_left_moving (as, lm) (s, [], Oc # xs) ires
  RR"
  apply(simp add: inv_check_left_moving.simps inv_check_left_moving_in_middle.simps)
  done

lemma inv_locate_n_b_Oc_via_at_begin_norm[simp]:
  "0 < abc_lm_v am n; 
  at_begin_norm (as, am) (n, aaa, Oc # xs) ires
   inv_locate_n_b (as, am) (n, Oc # aaa, xs) ires"
  apply(simp only: at_begin_norm.simps inv_locate_n_b.simps)
  apply(erule_tac exE)+
  apply(rename_tac lm1 lm2 rn)
  apply(rule_tac x = lm1 in exI, simp)
  apply(case_tac "length lm2", simp)
  apply(case_tac "lm2", simp, simp)
  apply(case_tac "lm2", auto simp: tape_of_nl_cons split: if_splits)
  done

lemma inv_locate_n_b_Oc_via_at_begin_fst_awtn[simp]: 
  "0 < abc_lm_v am n; 
   at_begin_fst_awtn (as, am) (n, aaa, Oc # xs) ires
  inv_locate_n_b (as, am) (n, Oc # aaa, xs) ires"
  apply(simp only: at_begin_fst_awtn.simps inv_locate_n_b.simps )
  apply(erule exE)+
  apply(rename_tac lm1 tn rn)
  apply(erule conjE)+
  apply(rule_tac x = lm1 in exI, rule_tac x = "[]" in exI, 
      rule_tac x = "Suc tn" in exI, rule_tac x = 0 in exI)
  apply(simp add: exp_ind del: replicate.simps)
  apply(rule conjI)+
   apply(auto)
  done

lemma inv_locate_n_b_Oc_via_inv_locate_n_a[simp]: 
  "0 < abc_lm_v am n; inv_locate_a (as, am) (n, aaa, Oc # xs) ires
  inv_locate_n_b (as, am) (n, Oc#aaa, xs) ires"
  apply(auto simp: inv_locate_a.simps at_begin_fst_bwtn.simps)
  done

lemma more_Oc_dec_on_right_moving[simp]: 
  "dec_on_right_moving (as, am) (s, aa, Bk # xs) ires; 
   Suc (length (takeWhile (λa. a = Oc) (tl aa)))
    length (takeWhile (λa. a = Oc) aa)
   Suc (length (takeWhile (λa. a = Oc) (tl aa))) 
    < length (takeWhile (λa. a = Oc) aa)"
  apply(simp only: dec_on_right_moving.simps)
  apply(erule exE)+
  apply(rename_tac ml mr rn)
  apply(case_tac ml, auto split: if_splits )
  done

lemma crsp_step_dec_b_suc_pre:
  assumes layout: "ly = layout_of ap"
    and crsp: "crsp ly (as, lm) (s, l, r) ires"
    and inv_start: "inv_locate_a (as, lm) (n, la, ra) ires"
    and fetch: "abc_fetch as ap = Some (Dec n e)"
    and dec_suc: "0 < abc_lm_v lm n"
    and f: "f = (λ stp. (steps (start_of ly as + 2 * n, la, ra) (ci ly (start_of ly as) (Dec n e), 
            start_of ly as - Suc 0) stp, start_of ly as, n))"
    and P: "P = (λ ((s, l, r), ss, x). s = start_of ly as + 2*n + 16)"
    and Q: "Q = (λ ((s, l, r), ss, x). dec_inv_2 ly x e (as, lm) (s, l, r) ires)"
  shows " stp. P (f stp)  Q(f stp)"
proof(rule_tac LE = abc_dec_2_LE in halt_lemma2)
  show "wf abc_dec_2_LE" by(intro wf_dec2_le)
next
  show "Q (f 0)"
    using layout fetch inv_start
    apply(simp add: f steps.simps Q)
    apply(simp only: dec_inv_2.simps)
    apply(auto simp: Let_def start_of_ge start_of_less inv_start dec_inv_2.simps)
    done
next
  show "¬ P (f 0)"
    using layout fetch
    apply(simp add: f steps.simps P)
    done
next
  show "n. ¬ P (f n)  Q (f n)  Q (f (Suc n))  (f (Suc n), f n)  abc_dec_2_LE"
    using fetch
  proof(rule_tac allI, rule_tac impI)
    fix na
    assume "¬ P (f na)  Q (f na)"
    thus "Q (f (Suc na))  (f (Suc na), f na)  abc_dec_2_LE"
      apply(simp add: f)
      apply(cases "steps ((start_of ly as + 2 * n), la, ra)
        (ci ly (start_of ly as) (Dec n e), start_of ly as - Suc 0) na", simp)
    proof -
      fix a b c 
      assume "¬ P ((a, b, c), start_of ly as, n)  Q ((a, b, c), start_of ly as, n)"
      thus "Q (step (a, b, c) (ci ly (start_of ly as) (Dec n e), start_of ly as - Suc 0), start_of ly as, n) 
               ((step (a, b, c) (ci ly (start_of ly as) (Dec n e), start_of ly as - Suc 0), start_of ly as, n), 
                   (a, b, c), start_of ly as, n)  abc_dec_2_LE"
        apply(simp add: Q)
        apply(erule_tac conjE)
        apply(cases c; cases "hd c")
           apply(simp_all add: dec_inv_2.simps Let_def)
           apply(simp_all split: if_splits)
        using fetch layout dec_suc
                            apply(auto simp: step.simps P dec_inv_2.simps Let_def abc_dec_2_LE_def lex_triple_def lex_pair_def lex_square_def
            fix_add numeral_3_eq_3) 
        done
    qed
  qed
qed

lemma crsp_abc_step_l_start_of[simp]: 
  "inv_stop (as, abc_lm_s lm n (abc_lm_v lm n - Suc 0)) 
  (start_of (layout_of ap) as + 2 * n + 16, a, b) ires;
   abc_lm_v lm n > 0;
   abc_fetch as ap = Some (Dec n e)
   crsp (layout_of ap) (abc_step_l (as, lm) (Some (Dec n e))) 
  (start_of (layout_of ap) as + 2 * n + 16, a, b) ires"
  by(auto simp: inv_stop.simps crsp.simps  abc_step_l.simps startof_Suc2)

lemma crsp_step_dec_b_suc:
  assumes layout: "ly = layout_of ap"
    and crsp: "crsp ly (as, lm) (s, l, r) ires"
    and inv_start: "inv_locate_a (as, lm) (n, la, ra) ires"
    and fetch: "abc_fetch as ap = Some (Dec n e)"
    and dec_suc: "0 < abc_lm_v lm n"
  shows "stp > 0. crsp ly (abc_step_l (as, lm) (Some (Dec n e)))
              (steps (start_of ly as + 2 * n, la, ra) (ci (layout_of ap) 
                  (start_of ly as) (Dec n e), start_of ly as - Suc 0) stp) ires"
  using assms
  apply(drule_tac crsp_step_dec_b_suc_pre, auto)
  apply(rename_tac stp a b)
  apply(rule_tac x = stp in exI)
  apply(case_tac stp, simp_all add: steps.simps dec_inv_2.simps)
  done

lemma crsp_step_dec_b:
  assumes layout: "ly = layout_of ap"
    and crsp: "crsp ly (as, lm) (s, l, r) ires"
    and inv_start: "inv_locate_a (as, lm) (n, la, ra) ires"
    and fetch: "abc_fetch as ap = Some (Dec n e)"
  shows "stp > 0. crsp ly (abc_step_l (as, lm) (Some (Dec n e)))
  (steps (start_of ly as + 2 * n, la, ra) (ci ly (start_of ly as) (Dec n e), start_of ly as - Suc 0) stp) ires"
  using assms
  apply(cases "abc_lm_v lm n = 0")
   apply(rule_tac crsp_step_dec_b_e, simp_all)
  apply(rule_tac crsp_step_dec_b_suc, simp_all)
  done

lemma crsp_step_dec: 
  assumes layout: "ly = layout_of ap"
    and crsp: "crsp ly (as, lm) (s, l, r) ires"
    and fetch: "abc_fetch as ap = Some (Dec n e)"
  shows "stp > 0. crsp ly (abc_step_l (as, lm) (Some (Dec n e)))
  (steps (s, l, r) (ci ly (start_of ly as) (Dec n e), start_of ly as - Suc 0) stp) ires"
proof(simp add: ci.simps)
  let ?off = "start_of ly as - Suc 0"
  let ?A = "findnth n"
  let ?B = "adjust (shift (shift tdec_b (2 * n)) ?off) (start_of ly e)"
  have " stp la ra. steps (s, l, r) (shift ?A ?off @ ?B, ?off) stp = (start_of ly as + 2*n, la, ra)
                     inv_locate_a (as, lm) (n, la, ra) ires"
  proof -
    have "stp l' r'. steps (Suc 0, l, r) (?A, 0) stp = (Suc (2 * n), l', r')  
                     inv_locate_a (as, lm) (n, l', r') ires"
      using assms
      apply(rule_tac findnth_correct, simp_all)
      done
    then obtain stp l' r' where a: 
      "steps (Suc 0, l, r) (?A, 0) stp = (Suc (2 * n), l', r')  
      inv_locate_a (as, lm) (n, l', r') ires" by blast
    then have "steps (Suc 0 + ?off, l, r) (shift ?A ?off, ?off) stp = (Suc (2 * n) + ?off, l', r')"
      apply(rule_tac tm_shift_eq_steps, simp_all)
      done
    moreover have "s = start_of ly as"
      using crsp
      apply(auto simp: crsp.simps)
      done
    ultimately show " stp la ra. steps (s, l, r) (shift ?A ?off @ ?B, ?off) stp = (start_of ly as + 2*n, la, ra)
                     inv_locate_a (as, lm) (n, la, ra) ires"
      using a
      apply(drule_tac B = ?B in tm_append_first_steps_eq, auto)
      apply(rule_tac x = stp in exI, simp)
      done
  qed
  from this obtain stpa la ra where a: 
    "steps (s, l, r) (shift ?A ?off @ ?B, ?off) stpa = (start_of ly as + 2*n, la, ra)
                     inv_locate_a (as, lm) (n, la, ra) ires" by blast
  have "stp. crsp ly (abc_step_l (as, lm) (Some (Dec n e)))
           (steps (start_of ly as + 2*n, la, ra) (shift ?A ?off @ ?B, ?off) stp) ires  stp > 0"
    using assms a
    apply(drule_tac crsp_step_dec_b, auto)
    apply(rename_tac stp)
    apply(rule_tac x = stp in exI, simp add: ci.simps)
    done
  then obtain stpb where b: 
    "crsp ly (abc_step_l (as, lm) (Some (Dec n e)))
    (steps (start_of ly as + 2*n, la, ra) (shift ?A ?off @ ?B, ?off) stpb) ires  stpb > 0" ..
  from a b show " stp>0. crsp ly (abc_step_l (as, lm) (Some (Dec n e)))
    (steps (s, l, r) (shift ?A ?off @ ?B, ?off) stp) ires"
    apply(rule_tac x = "stpa + stpb" in exI)
    apply(simp)
    done
qed    

subsection‹Crsp of Goto›

lemma crsp_step_goto:
  assumes layout: "ly = layout_of ap"
    and crsp: "crsp ly (as, lm) (s, l, r) ires"
  shows "stp>0. crsp ly (abc_step_l (as, lm) (Some (Goto n)))
  (steps (s, l, r) (ci ly (start_of ly as) (Goto n), 
            start_of ly as - Suc 0) stp) ires"
  using crsp
  apply(rule_tac x = "Suc 0" in exI)
  apply(cases r;cases "hd r")
     apply(simp_all add: ci.simps steps.simps step.simps crsp.simps fetch.simps abc_step_l.simps)
  done

lemma crsp_step_in:
  assumes layout: "ly = layout_of ap"
    and compile: "tp = tm_of ap"
    and crsp: "crsp ly (as, lm) (s, l, r) ires"
    and fetch: "abc_fetch as ap = Some ins"
  shows " stp>0. crsp ly (abc_step_l (as, lm) (Some ins))
                      (steps (s, l, r) (ci ly (start_of ly as) ins, start_of ly as - 1) stp) ires"
  using assms
  apply(cases ins, simp_all)
    apply(rule crsp_step_inc, simp_all)
   apply(rule crsp_step_dec, simp_all)
  apply(rule_tac crsp_step_goto, simp_all)
  done

lemma crsp_step:
  assumes layout: "ly = layout_of ap"
    and compile: "tp = tm_of ap"
    and crsp: "crsp ly (as, lm) (s, l, r) ires"
    and fetch: "abc_fetch as ap = Some ins"
  shows " stp>0. crsp ly (abc_step_l (as, lm) (Some ins))
                      (steps (s, l, r) (tp, 0) stp) ires"
proof -
  have " stp>0. crsp ly (abc_step_l (as, lm) (Some ins))
                      (steps (s, l, r) (ci ly (start_of ly as) ins, start_of ly as - 1) stp) ires"
    using assms
    apply(rule_tac crsp_step_in, simp_all)
    done
  from this obtain stp where d: "stp > 0  crsp ly (abc_step_l (as, lm) (Some ins))
                      (steps (s, l, r) (ci ly (start_of ly as) ins, start_of ly as - 1) stp) ires" ..
  obtain s' l' r' where e:
    "(steps (s, l, r) (ci ly (start_of ly as) ins, start_of ly as - 1) stp) = (s', l', r')"
    apply(cases "(steps (s, l, r) (ci ly (start_of ly as) ins, start_of ly as - 1) stp)")
    by blast
  then have "steps (s, l, r) (tp, 0) stp = (s', l', r')"
    using assms d
    apply(rule_tac steps_eq_in)
         apply(simp_all)
    apply(cases "(abc_step_l (as, lm) (Some ins))", simp add: crsp.simps)
    done    
  thus " stp>0. crsp ly (abc_step_l (as, lm) (Some ins)) (steps (s, l, r) (tp, 0) stp) ires"
    using d e
    apply(rule_tac x = stp in exI, simp)
    done
qed

lemma crsp_steps:
  assumes layout: "ly = layout_of ap"
    and compile: "tp = tm_of ap"
    and crsp: "crsp ly (as, lm) (s, l, r) ires"
  shows " stp. crsp ly (abc_steps_l (as, lm) ap n)
                      (steps (s, l, r) (tp, 0) stp) ires"
  using crsp
proof(induct n)
  case 0
  then show ?case  apply(rule_tac x = 0 in exI) 
    by(simp add: steps.simps abc_steps_l.simps)
next
  case (Suc n)
  then obtain stp where "crsp ly (abc_steps_l (as, lm) ap n) (steps0 (s, l, r) tp stp) ires"
    by blast
  thus ?case  
    apply(cases "(abc_steps_l (as, lm) ap n)", auto)
    apply(frule_tac abc_step_red, simp)
    apply(cases "abc_fetch (fst (abc_steps_l (as, lm) ap n)) ap", simp add: abc_step_l.simps, auto)
    apply(cases "steps (s, l, r) (tp, 0) stp", simp)
    using assms
    apply(drule_tac s = "fst (steps0 (s, l, r) (tm_of ap) stp)"
        and l = "fst (snd (steps0 (s, l, r) (tm_of ap) stp))"
        and r = "snd (snd (steps0 (s, l, r) (tm_of ap) stp))" in crsp_step, auto)
    by (metis steps_add)
qed


lemma tp_correct': 
  assumes layout: "ly = layout_of ap"
    and compile: "tp = tm_of ap"
    and crsp: "crsp ly (0, lm) (Suc 0, l, r) ires"
    and abc_halt: "abc_steps_l (0, lm) ap stp = (length ap, am)"
  shows " stp k. steps (Suc 0, l, r) (tp, 0) stp = (start_of ly (length ap), Bk # Bk # ires, <am> @ Bkk)"
  using assms
  apply(drule_tac n = stp in crsp_steps, auto)
  apply(rename_tac stpA)
  apply(rule_tac x = stpA in exI)
  apply(case_tac "steps (Suc 0, l, r) (tm_of ap, 0) stpA", simp add: crsp.simps)
  done

text‹The tp @ [(Nop, 0), (Nop, 0)] is nomoral turing machines, so we can use Hoare\_plus when composing with Mop machine›

lemma layout_id_cons: "layout_of (ap @ [p]) = layout_of ap @ [length_of p]"
  apply(simp add: layout_of.simps)
  done

lemma map_start_of_layout[simp]:  
  "map (start_of (layout_of xs @ [length_of x])) [0..<length xs] =  (map (start_of (layout_of xs)) [0..<length xs])"
  apply(auto)
  apply(simp add: layout_of.simps start_of.simps)
  done

lemma tpairs_id_cons: 
  "tpairs_of (xs @ [x]) = tpairs_of xs @ [(start_of (layout_of (xs @ [x])) (length xs), x)]"
  apply(auto simp: tpairs_of.simps layout_id_cons )
  done

lemma map_length_ci:
  "(map (length  (λ(xa, y). ci (layout_of xs @ [length_of x]) xa y)) (tpairs_of xs)) = 
  (map (length  (λ(x, y). ci (layout_of xs) x y)) (tpairs_of xs)) "
  apply(auto simp: ci.simps adjust.simps) apply(rename_tac A B)
  apply(case_tac B, auto simp: ci.simps adjust.simps)
  done

lemma length_tp'[simp]: 
  "ly = layout_of ap; tp = tm_of ap 
       length tp = 2 * sum_list (take (length ap) (layout_of ap))"
proof(induct ap arbitrary: ly tp rule: rev_induct)
  case Nil
  thus "?case"
    by(simp add: tms_of.simps tm_of.simps tpairs_of.simps)
next
  fix x xs ly tp
  assume ind: "ly tp. ly = layout_of xs; tp = tm_of xs  
    length tp = 2 * sum_list (take (length xs) (layout_of xs))"
    and layout: "ly = layout_of (xs @ [x])"
    and tp: "tp = tm_of (xs @ [x])"
  obtain ly' where a: "ly' = layout_of xs"
    by metis
  obtain tp' where b: "tp' = tm_of xs"
    by metis
  have c: "length tp' = 2 * sum_list (take (length xs) (layout_of xs))"
    using a b
    by(erule_tac ind, simp)
  thus "length tp = 2 * 
    sum_list (take (length (xs @ [x])) (layout_of (xs @ [x])))"
    using tp b
    apply(auto simp: layout_id_cons tm_of.simps tms_of.simps length_concat tpairs_id_cons map_length_ci)
    apply(cases x)
      apply(auto simp: ci.simps tinc_b_def tdec_b_def length_findnth adjust.simps length_of.simps
        split: abc_inst.splits)
    done
qed

lemma length_tp:
  "ly = layout_of ap; tp = tm_of ap  
  start_of ly (length ap) = Suc (length tp div 2)"
  apply(frule_tac length_tp', simp_all)
  apply(simp add: start_of.simps)
  done

lemma compile_correct_halt: 
  assumes layout: "ly = layout_of ap"
    and compile: "tp = tm_of ap"
    and crsp: "crsp ly (0, lm) (Suc 0, l, r) ires"
    and abc_halt: "abc_steps_l (0, lm) ap stp = (length ap, am)"
    and rs_loc: "n < length am"
    and rs: "abc_lm_v am n = rs"
    and off: "off = length tp div 2"
  shows " stp i j. steps (Suc 0, l, r) (tp @ shift (mopup n) off, 0) stp = (0, Bki @ Bk # Bk # ires, OcSuc rs @ Bkj)"
proof -
  have " stp k. steps (Suc 0, l, r) (tp, 0) stp = (Suc off, Bk # Bk # ires, <am> @ Bkk)"
    using assms tp_correct'[of ly ap tp lm l r ires stp am]
    by(simp add: length_tp)
  then obtain stp k where "steps (Suc 0, l, r) (tp, 0) stp = (Suc off, Bk # Bk # ires, <am> @ Bkk)"
    by blast
  then have a: "steps (Suc 0, l, r) (tp@shift (mopup n) off , 0) stp = (Suc off, Bk # Bk # ires, <am> @ Bkk)"
    using assms
    by(auto intro: tm_append_first_steps_eq)
  have " stp i j. (steps (Suc 0, Bk # Bk # ires, <am> @ Bk  k) (mopup_a n @ shift mopup_b (2 * n), 0) stp)
    = (0, Bki @ Bk # Bk # ires, Oc # Oc rs @ Bkj)"
    using assms
    by(rule_tac mopup_correct, auto simp: abc_lm_v.simps)
  then obtain stpb i j where 
    "steps (Suc 0, Bk # Bk # ires, <am> @ Bk  k) (mopup_a n @ shift mopup_b (2 * n), 0) stpb
    = (0, Bki @ Bk # Bk # ires, Oc # Oc rs @ Bkj)" by blast
  then have b: "steps (Suc 0 + off, Bk # Bk # ires, <am> @ Bk  k) (tp @ shift (mopup n) off, 0) stpb
    = (0, Bki @ Bk # Bk # ires, Oc # Oc rs @ Bkj)"
    using assms wf_mopup
    apply(drule_tac tm_append_second_halt_eq, auto)
    done
  from a b show "?thesis"
    by(rule_tac x = "stp + stpb" in exI, simp add: steps_add)
qed

declare mopup.simps[simp del]
lemma abc_step_red2:
  "abc_steps_l (s, lm) p (Suc n) = (let (as', am') = abc_steps_l (s, lm) p n in
                                    abc_step_l (as', am') (abc_fetch as' p))"
  apply(cases "abc_steps_l (s, lm) p n", simp)
  apply(drule_tac abc_step_red, simp)
  done

lemma crsp_steps2:
  assumes 
    layout: "ly = layout_of ap"
    and compile: "tp = tm_of ap"
    and crsp: "crsp ly (0, lm) (Suc 0, l, r) ires"
    and nothalt: "as < length ap"
    and aexec: "abc_steps_l (0, lm) ap stp = (as, am)"
  shows "stpastp. crsp ly (as, am) (steps (Suc 0, l, r) (tp, 0) stpa) ires"
  using nothalt aexec
proof(induct stp arbitrary: as am)
  case 0
  thus "?case"
    using crsp
    by(rule_tac x = 0 in exI, auto simp: abc_steps_l.simps steps.simps crsp)
next
  case (Suc stp as am)
  have ind: 
    " as am.  as < length ap; abc_steps_l (0, lm) ap stp = (as, am) 
     stpastp. crsp ly (as, am) (steps (Suc 0, l, r) (tp, 0) stpa) ires" by fact
  have a: "as < length ap" by fact
  have b: "abc_steps_l (0, lm) ap (Suc stp) = (as, am)" by fact
  obtain as' am' where c: "abc_steps_l (0, lm) ap stp = (as', am')" 
    by(cases "abc_steps_l (0, lm) ap stp", auto)
  then have d: "as' < length ap"
    using a b
    by(simp add: abc_step_red2, cases "as' < length ap", simp,
        simp add: abc_fetch.simps abc_steps_l.simps abc_step_l.simps)
  have "stpastp. crsp ly (as', am') (steps (Suc 0, l, r) (tp, 0) stpa) ires"
    using d c ind by simp
  from this obtain stpa where e: 
    "stpa  stp   crsp ly (as', am') (steps (Suc 0, l, r) (tp, 0) stpa) ires"
    by blast
  obtain s' l' r' where f: "steps (Suc 0, l, r) (tp, 0) stpa = (s', l', r')"
    by(cases "steps (Suc 0, l, r) (tp, 0) stpa", auto)
  obtain ins where g: "abc_fetch as' ap = Some ins" using d 
    by(cases "abc_fetch as' ap",auto simp: abc_fetch.simps)
  then have "stp> (0::nat). crsp ly (abc_step_l (as', am') (Some ins)) 
    (steps (s', l', r') (tp, 0) stp) ires "
    using layout compile e f 
    by(rule_tac crsp_step, simp_all)
  then obtain stpb where "stpb > 0  crsp ly (abc_step_l (as', am') (Some ins)) 
    (steps (s', l', r') (tp, 0) stpb) ires" ..
  from this show "?case" using b e g f c
    by(rule_tac x = "stpa + stpb" in exI, simp add: steps_add abc_step_red2)
qed

lemma compile_correct_unhalt: 
  assumes layout: "ly = layout_of ap"
    and compile: "tp = tm_of ap"
    and crsp: "crsp ly (0, lm) (1, l, r) ires"
    and off: "off = length tp div 2"
    and abc_unhalt: " stp. (λ (as, am). as < length ap) (abc_steps_l (0, lm) ap stp)"
  shows " stp.¬ is_final (steps (1, l, r) (tp @ shift (mopup n) off, 0) stp)"
  using assms
proof(rule_tac allI, rule_tac notI)
  fix stp
  assume h: "is_final (steps (1, l, r) (tp @ shift (mopup n) off, 0) stp)"
  obtain as am where a: "abc_steps_l (0, lm) ap stp = (as, am)"
    by(cases "abc_steps_l (0, lm) ap stp", auto)
  then have b: "as < length ap"
    using abc_unhalt
    by(erule_tac x = stp in allE, simp)
  have " stpastp. crsp ly (as, am) (steps (1, l, r) (tp, 0) stpa) ires "
    using assms b a
    apply(simp add: numeral)
    apply(rule_tac crsp_steps2)
        apply(simp_all)
    done
  then obtain stpa where 
    "stpastp  crsp ly (as, am) (steps (1, l, r) (tp, 0) stpa) ires" ..
  then obtain s' l' r' where b: "(steps (1, l, r) (tp, 0) stpa) = (s', l', r')  
       stpastp  crsp ly (as, am) (s', l', r') ires"
    by(cases "steps (1, l, r) (tp, 0) stpa", auto)
  hence c:
    "(steps (1, l, r) (tp @ shift (mopup n) off, 0) stpa) = (s', l', r')"
    by(rule_tac tm_append_first_steps_eq, simp_all add: crsp.simps)
  from b have d: "s' > 0  stpa  stp"
    by(simp add: crsp.simps)
  then obtain diff where e: "stpa = stp + diff" by (metis le_iff_add)
  obtain s'' l'' r'' where f:
    "steps (1, l, r) (tp @ shift (mopup n) off, 0) stp = (s'', l'', r'')  is_final (s'', l'', r'')"
    using h
    by(cases "steps (1, l, r) (tp @ shift (mopup n) off, 0) stp", auto)

  then have "is_final (steps (s'', l'', r'') (tp @ shift (mopup n) off, 0) diff)"
    by(auto intro: after_is_final)
  then have "is_final (steps (1, l, r) (tp @ shift (mopup n) off, 0) stpa)"
    using e f by simp
  from this and c d show "False" by simp
qed

end

Theory Abacus_Defs

(* Title: thys/Abacus.thy
   Author: Jian Xu, Xingyuan Zhang, and Christian Urban
   Modifications: Sebastiaan Joosten
*)

chapter ‹Alternative Definitions for Translating Abacus Machines to TMs›

theory Abacus_Defs
  imports Abacus
begin

abbreviation
  "layout  layout_of"

fun address :: "abc_prog  nat  nat"
  where
    "address p x = (Suc (sum_list (take x (layout p)))) "

abbreviation
  "TMGoto  [(Nop, 1), (Nop, 1)]"

abbreviation 
  "TMInc  [(W1, 1), (R, 2), (W1, 3), (R, 2), (W1, 3), (R, 4), 
            (L, 7), (W0, 5), (R, 6), (W0, 5), (W1, 3), (R, 6),
            (L, 8), (L, 7), (R, 9), (L, 7), (R, 10), (W0, 9)]"

abbreviation
  "TMDec  [(W1, 1), (R, 2), (L, 14), (R, 3), (L, 4), (R, 3),
             (R, 5), (W0, 4), (R, 6), (W0, 5), (L, 7), (L, 8),
             (L, 11), (W0, 7), (W1, 8), (R, 9), (L, 10), (R, 9),
             (R, 5), (W0, 10), (L, 12), (L, 11), (R, 13), (L, 11),
             (R, 17), (W0, 13), (L, 15), (L, 14), (R, 16), (L, 14),
             (R, 0), (W0, 16)]"

abbreviation
  "TMFindnth  findnth"

fun compile_goto :: "nat  instr list" 
  where
    "compile_goto s = shift TMGoto (s - 1)"

fun compile_inc :: "nat  nat  instr list"
  where
    "compile_inc s n = (shift (TMFindnth n) (s - 1)) @ (shift (shift TMInc (2 * n)) (s - 1))"

fun compile_dec :: "nat  nat  nat  instr list"
  where
    "compile_dec s n e = (shift (TMFindnth n) (s - 1)) @ (adjust (shift (shift TMDec (2 * n)) (s - 1)) e)"

fun compile :: "abc_prog  nat  abc_inst  instr list"
  where
    "compile ap s (Inc n) = compile_inc s n"
  | "compile ap s (Dec n e) = compile_dec s n (address ap e)"
  | "compile ap s (Goto e) = compile_goto (address ap e)"

lemma
  "compile ap s i = ci (layout ap) s i"
  apply(cases i)
    apply(simp add: ci.simps shift.simps start_of.simps tinc_b_def)
   apply(simp add: ci.simps shift.simps start_of.simps tdec_b_def)
  apply(simp add: ci.simps shift.simps start_of.simps)
  done


end

Theory Rec_Def

(* Title: thys/Rec_Def.thy
   Author: Jian Xu, Xingyuan Zhang, and Christian Urban
   Modifications: Sebastiaan Joosten
*)

theory Rec_Def
  imports Main
begin

datatype recf =  z
  |  s
  |  id nat nat
  |  Cn nat recf "recf list"
  |  Pr nat recf recf
  |  Mn nat recf 

definition pred_of_nl :: "nat list  nat list"
  where
    "pred_of_nl xs = butlast xs @ [last xs - 1]"

function rec_exec :: "recf  nat list  nat"
  where
    "rec_exec z xs = 0" |
    "rec_exec s xs = (Suc (xs ! 0))" |
    "rec_exec (id m n) xs = (xs ! n)" |
    "rec_exec (Cn n f gs) xs = 
     rec_exec f (map (λ a. rec_exec a xs) gs)" | 
    "rec_exec (Pr n f g) xs = 
     (if last xs = 0 then rec_exec f (butlast xs)
      else rec_exec g (butlast xs @ (last xs - 1) # [rec_exec (Pr n f g) (butlast xs @ [last xs - 1])]))" |
    "rec_exec (Mn n f) xs = (LEAST x. rec_exec f (xs @ [x]) = 0)"
  by pat_completeness auto

termination
  apply(relation "measures [λ (r, xs). size r, (λ (r, xs). last xs)]")
        apply(auto simp add: less_Suc_eq_le intro: trans_le_add2 size_list_estimation'[THEN trans_le_add1])
  done

inductive terminate :: "recf  nat list  bool"
  where
    termi_z: "terminate z [n]"
  | termi_s: "terminate s [n]"
  | termi_id: "n < m; length xs = m  terminate (id m n) xs"
  | termi_cn: "terminate f (map (λg. rec_exec g xs) gs); 
              g  set gs. terminate g xs; length xs = n  terminate (Cn n f gs) xs"
  | termi_pr: " y < x. terminate g (xs @ y # [rec_exec (Pr n f g) (xs @ [y])]);
              terminate f xs;
              length xs = n 
               terminate (Pr n f g) (xs @ [x])"
  | termi_mn: "length xs = n; terminate f (xs @ [r]); 
              rec_exec f (xs @ [r]) = 0;
               i < r. terminate f (xs @ [i])  rec_exec f (xs @ [i]) > 0  terminate (Mn n f) xs"


end

Theory Abacus_Hoare

(* Title: thys/Abacus_Hoare.thy
   Author: Jian Xu, Xingyuan Zhang, and Christian Urban
   Modifications: Sebastiaan Joosten
*)

theory Abacus_Hoare
  imports Abacus
begin

type_synonym abc_assert = "nat list  bool"

definition 
  assert_imp :: "('a  bool)  ('a  bool)  bool" ("_  _" [0, 0] 100)
  where
    "assert_imp P Q  xs. P xs  Q xs"

fun abc_holds_for :: "(nat list  bool)  (nat × nat list)  bool" ("_ abc'_holds'_for _" [100, 99] 100)
  where
    "P abc_holds_for (s, lm) = P lm"  

(* Hoare Rules *)
(* halting case *)
(*consts abc_Hoare_halt :: "abc_assert ⇒ abc_prog ⇒ abc_assert ⇒ bool" ("({(1_)}/ (_)/ {(1_)})" 50)*)

fun abc_final :: "(nat × nat list)  abc_prog  bool"
  where 
    "abc_final (s, lm) p = (s = length p)"

fun abc_notfinal :: "abc_conf  abc_prog  bool"
  where
    "abc_notfinal (s, lm) p = (s < length p)"

definition 
  abc_Hoare_halt :: "abc_assert  abc_prog  abc_assert  bool" ("({(1_)}/ (_)/ {(1_)})" 50)
  where
    "abc_Hoare_halt P p Q  lm. P lm  (n. abc_final (abc_steps_l (0, lm) p n) p  Q abc_holds_for (abc_steps_l (0, lm) p n))"

lemma abc_Hoare_haltI:
  assumes "lm. P lm  n. abc_final (abc_steps_l (0, lm) p n) p  Q abc_holds_for (abc_steps_l (0, lm) p n)"
  shows "{P} (p::abc_prog) {Q}"
  unfolding abc_Hoare_halt_def 
  using assms by auto

text ‹
  {P} A {Q}   {Q} B {S} 
  -----------------------------------------
  {P} A [+] B {S}
›

definition
  abc_Hoare_unhalt :: "abc_assert  abc_prog  bool" ("({(1_)}/ (_)) " 50)
  where
    "abc_Hoare_unhalt P p  args. P args  ( n .abc_notfinal (abc_steps_l (0, args) p n) p)"

lemma abc_Hoare_unhaltI:
  assumes "args n. P args  abc_notfinal (abc_steps_l (0, args) p n) p"
  shows "{P} (p::abc_prog) "
  unfolding abc_Hoare_unhalt_def 
  using assms by auto

fun abc_inst_shift :: "abc_inst  nat  abc_inst"
  where
    "abc_inst_shift (Inc m) n = Inc m" |
    "abc_inst_shift (Dec m e) n = Dec m (e + n)" |
    "abc_inst_shift (Goto m) n = Goto (m + n)"

fun abc_shift :: "abc_inst list  nat  abc_inst list" 
  where
    "abc_shift xs n = map (λ x. abc_inst_shift x n) xs" 

fun abc_comp :: "abc_inst list  abc_inst list  
                           abc_inst list" (infixl "[+]" 99)
  where
    "abc_comp al bl = (let al_len = length al in 
                           al @ abc_shift bl al_len)"

lemma abc_comp_first_step_eq_pre: 
  "s < length A
  abc_step_l (s, lm) (abc_fetch s (A [+] B)) = 
    abc_step_l (s, lm) (abc_fetch s A)"
  by(simp add: abc_step_l.simps abc_fetch.simps nth_append)

lemma abc_before_final: 
  "abc_final (abc_steps_l (0, lm) p n) p; p  []
    n'. abc_notfinal (abc_steps_l (0, lm) p n') p  
            abc_final (abc_steps_l (0, lm) p (Suc n')) p"
proof(induct n)
  case 0
  thus "?thesis"
    by(simp add: abc_steps_l.simps)
next
  case (Suc n)
  have ind: " abc_final (abc_steps_l (0, lm) p n) p; p  []  
    n'. abc_notfinal (abc_steps_l (0, lm) p n') p  abc_final (abc_steps_l (0, lm) p (Suc n')) p"
    by fact
  have final: "abc_final (abc_steps_l (0, lm) p (Suc n)) p" by fact
  have notnull: "p  []" by fact
  show "?thesis"
  proof(cases "abc_final (abc_steps_l (0, lm) p n) p")
    case True
    have "abc_final (abc_steps_l (0, lm) p n) p" by fact
    then have "n'. abc_notfinal (abc_steps_l (0, lm) p n') p  abc_final (abc_steps_l (0, lm) p (Suc n')) p"
      using ind notnull
      by simp
    thus "?thesis"
      by simp
  next
    case False
    have "¬ abc_final (abc_steps_l (0, lm) p n) p" by fact
    from final this have "abc_notfinal (abc_steps_l (0, lm) p n) p" 
      by(case_tac "abc_steps_l (0, lm) p n", simp add: abc_step_red2 
          abc_step_l.simps abc_fetch.simps split: if_splits)
    thus "?thesis"
      using final
      by(rule_tac x = n in exI, simp)
  qed
qed

lemma notfinal_Suc:
  "abc_notfinal (abc_steps_l (0, lm) A (Suc n)) A   
  abc_notfinal (abc_steps_l (0, lm) A n) A"
  apply(case_tac "abc_steps_l (0, lm) A n")
  apply(simp add: abc_step_red2 abc_fetch.simps abc_step_l.simps split: if_splits)
  done

lemma abc_comp_frist_steps_eq_pre: 
  assumes notfinal: "abc_notfinal (abc_steps_l (0, lm)  A n) A"
    and notnull: "A  []"
  shows "abc_steps_l (0, lm) (A [+] B) n = abc_steps_l (0, lm) A n"
  using notfinal
proof(induct n)
  case 0
  thus "?case"
    by(simp add: abc_steps_l.simps)
next
  case (Suc n)
  have ind: "abc_notfinal (abc_steps_l (0, lm) A n) A  abc_steps_l (0, lm) (A [+] B) n = abc_steps_l (0, lm) A n"
    by fact
  have h: "abc_notfinal (abc_steps_l (0, lm) A (Suc n)) A" by fact
  then have a: "abc_notfinal (abc_steps_l (0, lm) A n) A"
    by(simp add: notfinal_Suc)
  then have b: "abc_steps_l (0, lm) (A [+] B) n = abc_steps_l (0, lm) A n"
    using ind by simp
  obtain s lm' where c: "abc_steps_l (0, lm) A n = (s, lm')"
    by (metis prod.exhaust)
  then have d: "s < length A  abc_steps_l (0, lm) (A [+] B) n = (s, lm')" 
    using a b by simp
  thus "?case"
    using c
    by(simp add: abc_step_red2 abc_fetch.simps abc_step_l.simps nth_append)
qed

declare abc_shift.simps[simp del] abc_comp.simps[simp del]
lemma halt_steps2: "st  length A  abc_steps_l (st, lm) A stp = (st, lm)"
  apply(induct stp)
  by(simp_all add: abc_step_red2 abc_steps_l.simps abc_step_l.simps abc_fetch.simps)

lemma halt_steps: "abc_steps_l (length A, lm) A n = (length A, lm)"
  apply(induct n, simp add: abc_steps_l.simps)
  apply(simp add: abc_step_red2 abc_step_l.simps nth_append abc_fetch.simps)
  done

lemma abc_steps_add: 
  "abc_steps_l (as, lm) ap (m + n) = 
         abc_steps_l (abc_steps_l (as, lm) ap m) ap n"
  apply(induct m arbitrary: n as lm, simp add: abc_steps_l.simps)
proof -
  fix m n as lm
  assume ind: 
    "n as lm. abc_steps_l (as, lm) ap (m + n) = 
                   abc_steps_l (abc_steps_l (as, lm) ap m) ap n"
  show "abc_steps_l (as, lm) ap (Suc m + n) = 
             abc_steps_l (abc_steps_l (as, lm) ap (Suc m)) ap n"
    apply(insert ind[of as lm "Suc n"], simp)
    apply(insert ind[of as lm "Suc 0"], simp add: abc_steps_l.simps)
    apply(case_tac "(abc_steps_l (as, lm) ap m)", simp)
    apply(simp add: abc_steps_l.simps)
    apply(case_tac "abc_step_l (a, b) (abc_fetch a ap)", 
        simp add: abc_steps_l.simps)
    done
qed

lemma equal_when_halt: 
  assumes exc1: "abc_steps_l (s, lm) A na = (length A, lma)"
    and exc2: "abc_steps_l (s, lm) A nb = (length A, lmb)"
  shows "lma = lmb"
proof(cases "na > nb")
  case True
  then obtain d where "na = nb + d"
    by (metis add_Suc_right less_iff_Suc_add)
  thus "?thesis" using assms halt_steps
    by(simp add: abc_steps_add)
next
  case False
  then obtain d where "nb = na + d"
    by (metis add.comm_neutral less_imp_add_positive nat_neq_iff)
  thus "?thesis" using assms halt_steps
    by(simp add: abc_steps_add)
qed 

lemma abc_comp_frist_steps_halt_eq': 
  assumes final: "abc_steps_l (0, lm) A n = (length A, lm')"
    and notnull: "A  []"
  shows " n'. abc_steps_l (0, lm) (A [+] B) n' = (length A, lm')"
proof -
  have " n'. abc_notfinal (abc_steps_l (0, lm) A n') A  
    abc_final (abc_steps_l (0, lm) A (Suc n')) A"
    using assms
    by(rule_tac n = n in abc_before_final, simp_all)
  then obtain na where a:
    "abc_notfinal (abc_steps_l (0, lm) A na) A  
            abc_final (abc_steps_l (0, lm) A (Suc na)) A" ..
  obtain sa lma where b: "abc_steps_l (0, lm) A na = (sa, lma)"
    by (metis prod.exhaust)
  then have c: "abc_steps_l (0, lm) (A [+] B) na = (sa, lma)"
    using a abc_comp_frist_steps_eq_pre[of lm A na B] assms 
    by simp
  have d: "sa < length A" using b a by simp
  then have e: "abc_step_l (sa, lma) (abc_fetch sa (A [+] B)) = 
    abc_step_l (sa, lma) (abc_fetch sa A)"
    by(rule_tac abc_comp_first_step_eq_pre)
  from a have "abc_steps_l (0, lm) A (Suc na) = (length A, lm')"
    using final equal_when_halt
    by(case_tac "abc_steps_l (0, lm) A (Suc na)" , simp)
  then have "abc_steps_l (0, lm) (A [+] B) (Suc na) = (length A, lm')"
    using a b c e
    by(simp add: abc_step_red2)
  thus "?thesis"
    by blast
qed

lemma abc_exec_null: "abc_steps_l sam [] n = sam"
  apply(cases sam)
  apply(induct n)
   apply(auto simp: abc_step_red2)
   apply(auto simp: abc_step_l.simps abc_steps_l.simps abc_fetch.simps)
  done

lemma abc_comp_frist_steps_halt_eq: 
  assumes final: "abc_steps_l (0, lm) A n = (length A, lm')"
  shows " n'. abc_steps_l (0, lm) (A [+] B) n' = (length A, lm')"
  using final
  apply(case_tac "A = []")
   apply(rule_tac x = 0 in exI, simp add: abc_steps_l.simps abc_exec_null)
  apply(rule_tac abc_comp_frist_steps_halt_eq', simp_all)
  done


lemma abc_comp_second_step_eq: 
  assumes exec: "abc_step_l (s, lm) (abc_fetch s B) = (sa, lma)"
  shows "abc_step_l (s + length A, lm) (abc_fetch (s + length A) (A [+] B))
         = (sa + length A, lma)"
  using assms
  apply(auto simp: abc_step_l.simps abc_fetch.simps nth_append abc_comp.simps abc_shift.simps split : if_splits )
  apply(case_tac [!] "B ! s", auto simp: Let_def)
  done

lemma abc_comp_second_steps_eq:
  assumes exec: "abc_steps_l (0, lm) B n = (sa, lm')"
  shows "abc_steps_l (length A, lm) (A [+] B) n = (sa + length A, lm')"
  using assms
proof(induct n arbitrary: sa lm')
  case 0
  thus "?case"
    by(simp add: abc_steps_l.simps)
next
  case (Suc n)
  have ind: "sa lm'. abc_steps_l (0, lm) B n = (sa, lm')  
    abc_steps_l (length A, lm) (A [+] B) n = (sa + length A, lm')" by fact
  have exec: "abc_steps_l (0, lm) B (Suc n) = (sa, lm')" by fact
  obtain sb lmb where a: " abc_steps_l (0, lm) B n = (sb, lmb)"
    by (metis prod.exhaust)
  then have "abc_steps_l (length A, lm) (A [+] B) n = (sb + length A, lmb)"
    using ind by simp
  moreover have "abc_step_l (sb + length A, lmb) (abc_fetch (sb + length A) (A [+] B)) = (sa + length A, lm') "
    using a exec abc_comp_second_step_eq
    by(simp add: abc_step_red2)    
  ultimately show "?case"
    by(simp add: abc_step_red2)
qed

lemma length_abc_comp[simp, intro]: 
  "length (A [+] B) = length A + length B"
  by(auto simp: abc_comp.simps abc_shift.simps)   

lemma abc_Hoare_plus_halt : 
  assumes A_halt : "{P} (A::abc_prog) {Q}"
    and B_halt : "{Q} (B::abc_prog) {S}"
  shows "{P} (A [+] B) {S}"
proof(rule_tac abc_Hoare_haltI)
  fix lm
  assume a: "P lm"
  then obtain na lma where 
    "abc_final (abc_steps_l (0, lm) A na) A"
    and b: "abc_steps_l (0, lm) A na = (length A, lma)"
    and c: "Q abc_holds_for (length A, lma)"
    using A_halt unfolding abc_Hoare_halt_def
    by (metis (full_types) abc_final.simps abc_holds_for.simps prod.exhaust)
  have " n. abc_steps_l (0, lm) (A [+] B) n = (length A, lma)"
    using abc_comp_frist_steps_halt_eq b
    by(simp)
  then obtain nx where h1: "abc_steps_l (0, lm) (A [+] B) nx = (length A, lma)" ..   
  from c have "Q lma"
    using c unfolding abc_holds_for.simps
    by simp
  then obtain nb lmb where
    "abc_final (abc_steps_l (0, lma) B nb) B"
    and d: "abc_steps_l (0, lma) B nb = (length B, lmb)"
    and e: "S abc_holds_for (length B, lmb)"
    using B_halt unfolding abc_Hoare_halt_def
    by (metis (full_types) abc_final.simps abc_holds_for.simps prod.exhaust)
  have h2: "abc_steps_l (length A, lma) (A [+] B) nb = (length B + length A, lmb)"
    using d abc_comp_second_steps_eq
    by simp
  thus "n. abc_final (abc_steps_l (0, lm) (A [+] B) n) (A [+] B) 
    S abc_holds_for abc_steps_l (0, lm) (A [+] B) n"
    using h1 e
    by(rule_tac x = "nx + nb" in exI, simp add: abc_steps_add)
qed

lemma abc_unhalt_append_eq:
  assumes unhalt: "{P} (A::abc_prog) "
    and P: "P args"
  shows "abc_steps_l (0, args) (A [+] B) stp = abc_steps_l (0, args) A stp"
proof(induct stp)
  case 0
  thus "?case"
    by(simp add: abc_steps_l.simps)
next
  case (Suc stp)
  have ind: "abc_steps_l (0, args) (A [+] B) stp = abc_steps_l (0, args) A stp"
    by fact
  obtain s nl where a: "abc_steps_l (0, args) A stp = (s, nl)"
    by (metis prod.exhaust)
  then have b: "s < length A"
    using unhalt P
    apply(auto simp: abc_Hoare_unhalt_def)
    by (metis abc_notfinal.simps)
  thus "?case"
    using a ind
    by(simp add: abc_step_red2 abc_step_l.simps abc_fetch.simps nth_append abc_comp.simps)
qed

lemma abc_Hoare_plus_unhalt1: 
  "{P} (A::abc_prog)   {P} (A [+] B) "
  apply(rule abc_Hoare_unhaltI)
  apply(subst abc_unhalt_append_eq,force,force)
  by (metis (mono_tags, lifting) abc_notfinal.elims(3) abc_notfinal.simps add_diff_inverse_nat 
      abc_Hoare_unhalt_def le_imp_less_Suc length_abc_comp not_less_eq order_refl trans_le_add1)

lemma notfinal_all_before:
  "abc_notfinal (abc_steps_l (0, args) A x) A; yx 
   abc_notfinal (abc_steps_l (0, args) A y) A "
  apply(subgoal_tac " d. x = y + d", auto)
   apply(cases "abc_steps_l (0, args) A y",simp)
   apply(rule classical, simp add: abc_steps_add leI halt_steps2)
  by arith

lemma abc_Hoare_plus_unhalt2':
  assumes unhalt: "{Q} (B::abc_prog) "
    and halt: "{P} (A::abc_prog) {Q}"
    and notnull: "A  []"
    and P: "P args" 
  shows "abc_notfinal (abc_steps_l (0, args) (A [+] B) n) (A [+] B)"
proof -
  obtain st nl stp where a: "abc_final (abc_steps_l (0, args) A stp) A"
    and b: "Q abc_holds_for (length A, nl)"
    and c: "abc_steps_l (0, args) A stp = (st, nl)"
    using halt P unfolding abc_Hoare_halt_def
    by (metis abc_holds_for.simps prod.exhaust)
  obtain stpa where d: 
    "abc_notfinal (abc_steps_l (0, args) A stpa) A  abc_final (abc_steps_l (0, args) A (Suc stpa)) A"
    using abc_before_final[of args A stp,OF a notnull] by metis
  thus "?thesis"
  proof(cases "n < Suc stpa")
    case True
    have h: "n < Suc stpa" by fact
    then have "abc_notfinal (abc_steps_l (0, args) A n) A"
      using d
      by(rule_tac notfinal_all_before, auto)
    moreover then have "abc_steps_l (0, args) (A [+] B) n = abc_steps_l (0, args) A n"
      using notnull
      by(rule_tac abc_comp_frist_steps_eq_pre, simp_all)
    ultimately show "?thesis"
      by(case_tac "abc_steps_l (0, args) A n", simp)
  next
    case False
    have "¬ n < Suc stpa" by fact
    then obtain d where i1: "n = Suc stpa + d"
      by (metis add_Suc less_iff_Suc_add not_less_eq)
    have "abc_steps_l (0, args) A (Suc stpa) = (length A, nl)"
      using d a c
      apply(case_tac "abc_steps_l (0, args) A stp", simp add: equal_when_halt)
      by(case_tac "abc_steps_l (0, args) A (Suc stpa)", simp add: equal_when_halt)
    moreover have  "abc_steps_l (0, args) (A [+] B) stpa = abc_steps_l (0, args) A stpa"
      using notnull d
      by(rule_tac abc_comp_frist_steps_eq_pre, simp_all)
    ultimately have i2: "abc_steps_l (0, args) (A [+] B) (Suc stpa) = (length A, nl)"
      using d
      apply(case_tac "abc_steps_l (0, args) A stpa", simp)
      by(simp add: abc_step_red2 abc_steps_l.simps abc_fetch.simps abc_comp.simps nth_append)
    obtain s' nl' where i3:"abc_steps_l (0, nl) B d = (s', nl')"
      by (metis prod.exhaust)
    then have i4: "abc_steps_l (0, args) (A [+] B) (Suc stpa + d) = (length A + s', nl')"
      using i2  apply(simp only: abc_steps_add)
      using abc_comp_second_steps_eq[of nl B d s' nl']
      by simp
    moreover have "s' < length B"
      using unhalt b i3
      apply(simp add: abc_Hoare_unhalt_def)
      apply(erule_tac x = nl in allE, simp)
      by(erule_tac x = d in allE, simp)
    ultimately show "?thesis"
      using i1
      by(simp)
  qed
qed

lemma abc_comp_null_left[simp]: "[] [+] A = A"
proof(induct A)
  case (Cons a A)
  then show ?case 
    apply(cases a)
    by(auto simp: abc_comp.simps abc_shift.simps)
qed (auto simp: abc_comp.simps abc_shift.simps)

lemma abc_comp_null_right[simp]: "A [+] [] = A"
proof(induct A)
  case (Cons a A)
  then show ?case 
    apply(cases a)
    by(auto simp: abc_comp.simps abc_shift.simps)
qed (auto simp: abc_comp.simps abc_shift.simps)

lemma abc_Hoare_plus_unhalt2:
  "{Q} (B::abc_prog); {P} (A::abc_prog) {Q} {P} (A [+] B) "
  apply(case_tac "A = []")
   apply(simp add: abc_Hoare_halt_def abc_Hoare_unhalt_def abc_exec_null)
  apply(rule_tac abc_Hoare_unhaltI)
  apply(erule_tac abc_Hoare_plus_unhalt2', simp)
   apply(simp, simp)
  done

end

Theory Recursive

(* Title: thys/Recursive.thy
   Author: Jian Xu, Xingyuan Zhang, and Christian Urban
   Modifications: Sebastiaan Joosten
*)

theory Recursive
  imports Abacus Rec_Def Abacus_Hoare
begin

fun addition :: "nat  nat  nat  abc_prog"
  where
    "addition m n p = [Dec m 4, Inc n, Inc p, Goto 0, Dec p 7, Inc m, Goto 4]"

fun mv_box :: "nat  nat  abc_prog"
  where
    "mv_box m n = [Dec m 3, Inc n, Goto 0]"

text ‹The compilation of z›-operator.›
definition rec_ci_z :: "abc_inst list"
  where
    "rec_ci_z  [Goto 1]"

text ‹The compilation of s›-operator.›
definition rec_ci_s :: "abc_inst list"
  where
    "rec_ci_s  (addition 0 1 2 [+] [Inc 1])"


text ‹The compilation of id i j›-operator›
fun rec_ci_id :: "nat  nat  abc_inst list"
  where
    "rec_ci_id i j = addition j i (i + 1)"

fun mv_boxes :: "nat  nat  nat  abc_inst list"
  where
    "mv_boxes ab bb 0 = []" |
    "mv_boxes ab bb (Suc n) = mv_boxes ab bb n [+] mv_box (ab + n) (bb + n)"

fun empty_boxes :: "nat  abc_inst list"
  where
    "empty_boxes 0 = []" |
    "empty_boxes (Suc n) = empty_boxes n [+] [Dec n 2, Goto 0]"

fun cn_merge_gs ::
  "(abc_inst list × nat × nat) list  nat  abc_inst list"
  where
    "cn_merge_gs [] p = []" |
    "cn_merge_gs (g # gs) p = 
      (let (gprog, gpara, gn) = g in 
         gprog [+] mv_box gpara p [+] cn_merge_gs gs (Suc p))"


text ‹
  The compiler of recursive functions, where rec_ci recf› return 
  (ap, arity, fp)›, where ap› is the Abacus program, arity› is the 
  arity of the recursive function recf›, 
  fp› is the amount of memory which is going to be
  used by ap› for its execution. 
›

fun rec_ci :: "recf  abc_inst list × nat × nat"
  where
    "rec_ci z = (rec_ci_z, 1, 2)" |
    "rec_ci s = (rec_ci_s, 1, 3)" |
    "rec_ci (id m n) = (rec_ci_id m n, m, m + 2)" |
    "rec_ci (Cn n f gs) = 
      (let cied_gs = map (λ g. rec_ci g) gs in
       let (fprog, fpara, fn) = rec_ci f in 
       let pstr = Max (set (Suc n # fn # (map (λ (aprog, p, n). n) cied_gs))) in
       let qstr = pstr + Suc (length gs) in 
       (cn_merge_gs cied_gs pstr [+] mv_boxes 0 qstr n [+] 
          mv_boxes pstr 0 (length gs) [+] fprog [+] 
            mv_box fpara pstr [+] empty_boxes (length gs) [+] 
             mv_box pstr n [+] mv_boxes qstr 0 n, n,  qstr + n))" |
    "rec_ci (Pr n f g) = 
         (let (fprog, fpara, fn) = rec_ci f in 
          let (gprog, gpara, gn) = rec_ci g in 
          let p = Max (set ([n + 3, fn, gn])) in 
          let e = length gprog + 7 in 
           (mv_box n p [+] fprog [+] mv_box n (Suc n) [+] 
               (([Dec p e] [+] gprog [+] 
                 [Inc n, Dec (Suc n) 3, Goto 1]) @
                     [Dec (Suc (Suc n)) 0, Inc (Suc n), Goto (length gprog + 4)]),
             Suc n, p + 1))" |
    "rec_ci (Mn n f) =
         (let (fprog, fpara, fn) = rec_ci f in 
          let len = length (fprog) in 
            (fprog @ [Dec (Suc n) (len + 5), Dec (Suc n) (len + 3),
             Goto (len + 1), Inc n, Goto 0], n, max (Suc n) fn))"

declare rec_ci.simps [simp del] rec_ci_s_def[simp del] 
  rec_ci_z_def[simp del] rec_ci_id.simps[simp del]
  mv_boxes.simps[simp del] 
  mv_box.simps[simp del] addition.simps[simp del]

declare abc_steps_l.simps[simp del] abc_fetch.simps[simp del] 
  abc_step_l.simps[simp del] 

inductive_cases terminate_pr_reverse: "terminate (Pr n f g) xs"

inductive_cases terminate_z_reverse[elim!]: "terminate z xs"

inductive_cases terminate_s_reverse[elim!]: "terminate s xs"

inductive_cases terminate_id_reverse[elim!]: "terminate (id m n) xs"

inductive_cases terminate_cn_reverse[elim!]: "terminate (Cn n f gs) xs"

inductive_cases terminate_mn_reverse[elim!]:"terminate (Mn n f) xs"

fun addition_inv :: "nat × nat list  nat  nat  nat      
                     nat list  bool"
  where
    "addition_inv (as, lm') m n p lm = 
        (let sn = lm ! n in
         let sm = lm ! m in
         lm ! p = 0 
             (if as = 0 then  x. x  lm ! m  lm' = lm[m := x,
                                    n := (sn + sm - x), p := (sm - x)]
             else if as = 1 then  x. x < lm ! m  lm' = lm[m := x,
                            n := (sn + sm - x - 1), p := (sm - x - 1)]
             else if as = 2 then  x. x < lm ! m  lm' = lm[m := x, 
                               n := (sn + sm - x), p := (sm - x - 1)]
             else if as = 3 then  x. x < lm ! m  lm' = lm[m := x,
                                   n := (sn + sm - x), p := (sm - x)]
             else if as = 4 then  x. x  lm ! m  lm' = lm[m := x,
                                       n := (sn + sm), p := (sm - x)] 
             else if as = 5 then  x. x < lm ! m  lm' = lm[m := x, 
                                  n := (sn + sm), p := (sm - x - 1)] 
             else if as = 6 then  x. x < lm ! m  lm' =
                     lm[m := Suc x, n := (sn + sm), p := (sm - x - 1)]
             else if as = 7 then lm' = lm[m := sm, n := (sn + sm)]
             else False))"

fun addition_stage1 :: "nat × nat list  nat  nat  nat"
  where
    "addition_stage1 (as, lm) m p = 
          (if as = 0  as = 1  as = 2  as = 3 then 2 
           else if as = 4  as = 5  as = 6 then 1
           else 0)"

fun addition_stage2 :: "nat × nat list  nat   nat  nat"
  where
    "addition_stage2 (as, lm) m p = 
              (if 0  as  as  3 then lm ! m
               else if 4  as  as  6 then lm ! p
               else 0)"

fun addition_stage3 :: "nat × nat list  nat  nat  nat"
  where
    "addition_stage3 (as, lm) m p = 
             (if as = 1 then 4  
              else if as = 2 then 3 
              else if as = 3 then 2
              else if as = 0 then 1 
              else if as = 5 then 2
              else if as = 6 then 1 
              else if as = 4 then 0 
              else 0)"

fun addition_measure :: "((nat × nat list) × nat × nat)  
                                                 (nat × nat × nat)"
  where
    "addition_measure ((as, lm), m, p) =
     (addition_stage1 (as, lm) m p, 
      addition_stage2 (as, lm) m p,
      addition_stage3 (as, lm) m p)"

definition addition_LE :: "(((nat × nat list) × nat × nat) × 
                          ((nat × nat list) × nat × nat)) set"
  where "addition_LE  (inv_image lex_triple addition_measure)"

lemma wf_additon_LE[simp]: "wf addition_LE"
  by(auto simp: addition_LE_def lex_triple_def lex_pair_def)

declare addition_inv.simps[simp del]

lemma update_zero_to_zero[simp]: "am ! n = (0::nat); n < length am  am[n := 0] = am"
  apply(simp add: list_update_same_conv)
  done

lemma addition_inv_init: 
  "m  n; max m n < p; length lm > p; lm ! p = 0 
                                   addition_inv (0, lm) m n p lm"
  apply(simp add: addition_inv.simps Let_def )
  apply(rule_tac x = "lm ! m" in exI, simp)
  done

lemma abs_fetch[simp]:
  "abc_fetch 0 (addition m n p) = Some (Dec m 4)"
  "abc_fetch (Suc 0) (addition m n p) = Some (Inc n)"
  "abc_fetch 2 (addition m n p) = Some (Inc p)"
  "abc_fetch 3 (addition m n p) = Some (Goto 0)"
  "abc_fetch 4 (addition m n p) = Some (Dec p 7)"
  "abc_fetch 5 (addition m n p) = Some (Inc m)"
  "abc_fetch 6 (addition m n p) = Some (Goto 4)"
  by(simp_all add: abc_fetch.simps addition.simps)

lemma exists_small_list_elem1[simp]:
  "m  n; p < length lm; lm ! p = 0; m < p; n < p; x  lm ! m; 0 < x
  xa<lm ! m. lm[m := x, n := lm ! n + lm ! m - x, 
                    p := lm ! m - x, m := x - Suc 0] =
                 lm[m := xa, n := lm ! n + lm ! m - Suc xa,
                    p := lm ! m - Suc xa]"
  apply(cases x, simp, simp)
  apply(rule_tac x = "x - 1" in exI, simp add: list_update_swap 
      list_update_overwrite)
  done

lemma exists_small_list_elem2[simp]:
  "m  n; p < length lm; lm ! p = 0; m < p; n < p; x < lm ! m
    xa<lm ! m. lm[m := x, n := lm ! n + lm ! m - Suc x,
                      p := lm ! m - Suc x, n := lm ! n + lm ! m - x]
                 = lm[m := xa, n := lm ! n + lm ! m - xa, 
                      p := lm ! m - Suc xa]"
  apply(rule_tac x = x in exI, 
      simp add: list_update_swap list_update_overwrite)
  done

lemma exists_small_list_elem3[simp]: 
  "m  n; p < length lm; lm ! p = 0; m < p; n < p; x < lm ! m
    xa<lm ! m. lm[m := x, n := lm ! n + lm ! m - x, 
                          p := lm ! m - Suc x, p := lm ! m - x]
                 = lm[m := xa, n := lm ! n + lm ! m - xa, 
                          p := lm ! m - xa]"
  apply(rule_tac x = x in exI, simp add: list_update_overwrite)
  done

lemma exists_small_list_elem4[simp]: 
  "m  n; p < length lm; lm ! p = (0::nat); m < p; n < p; x < lm ! m
   xalm ! m. lm[m := x, n := lm ! n + lm ! m - x,
                                   p := lm ! m - x] = 
                  lm[m := xa, n := lm ! n + lm ! m - xa, 
                                   p := lm ! m - xa]"
  apply(rule_tac x = x in exI, simp)
  done

lemma exists_small_list_elem5[simp]: 
  "m  n; p < length lm; lm ! p = 0; m < p; n < p;
    x  lm ! m; lm ! m  x
   xa<lm ! m. lm[m := x, n := lm ! n + lm ! m, 
                       p := lm ! m - x, p := lm ! m - Suc x] 
               = lm[m := xa, n := lm ! n + lm ! m, 
                       p := lm ! m - Suc xa]"
  apply(rule_tac x = x in exI, simp add: list_update_overwrite)
  done

lemma exists_small_list_elem6[simp]:
  "m  n; p < length lm; lm ! p = 0; m < p; n < p; x < lm ! m
   xa<lm ! m. lm[m := x, n := lm ! n + lm ! m,
                             p := lm ! m - Suc x, m := Suc x]
                = lm[m := Suc xa, n := lm ! n + lm ! m, 
                             p := lm ! m - Suc xa]"
  apply(rule_tac x = x in exI, 
      simp add: list_update_swap list_update_overwrite)
  done

lemma exists_small_list_elem7[simp]: 
  "m  n; p < length lm; lm ! p = 0; m < p; n < p; x < lm ! m
   xalm ! m. lm[m := Suc x, n := lm ! n + lm ! m, 
                             p := lm ! m - Suc x] 
               = lm[m := xa, n := lm ! n + lm ! m, p := lm ! m - xa]"
  apply(rule_tac x = "Suc x" in exI, simp)
  done

lemma abc_steps_zero: "abc_steps_l asm ap 0 = asm"
  apply(cases asm, simp add: abc_steps_l.simps)
  done

lemma list_double_update_2:
  "lm[a := x, b := y, a := z] = lm[b := y, a:=z]"
  by (metis list_update_overwrite list_update_swap)

declare Let_def[simp]
lemma addition_halt_lemma: 
  "m  n; max m n < p; length lm > p 
  na. ¬ (λ(as, lm') (m, p). as = 7) 
        (abc_steps_l (0, lm) (addition m n p) na) (m, p)  
  addition_inv (abc_steps_l (0, lm) (addition m n p) na) m n p lm 
 addition_inv (abc_steps_l (0, lm) (addition m n p) 
                                 (Suc na)) m n p lm 
   ((abc_steps_l (0, lm) (addition m n p) (Suc na), m, p), 
     abc_steps_l (0, lm) (addition m n p) na, m, p)  addition_LE"
proof -
  assume assms:"mn" "max m n < p" "length lm > p"
  { fix na
    obtain a b where ab:"abc_steps_l (0, lm) (addition m n p) na = (a, b)" by force
    assume assms2: "¬ (λ(as, lm') (m, p). as = 7) 
        (abc_steps_l (0, lm) (addition m n p) na) (m, p)"
      "addition_inv (abc_steps_l (0, lm) (addition m n p) na) m n p lm"
    have r1:"addition_inv (abc_steps_l (0, lm) (addition m n p) 
                                 (Suc na)) m n p lm" using assms(1-3) assms2
      unfolding abc_step_red2 ab abc_step_l.simps abc_lm_v.simps abc_lm_s.simps 
        addition_inv.simps
      by (auto split:if_splits simp add: addition_inv.simps Suc_diff_Suc)
    have r2:"((abc_steps_l (0, lm) (addition m n p) (Suc na), m, p), 
              abc_steps_l (0, lm) (addition m n p) na, m, p)  addition_LE" using assms(1-3) assms2
      unfolding abc_step_red2 ab 
      apply(auto split:if_splits simp add: addition_inv.simps abc_steps_zero)
      by(auto simp add: addition_LE_def lex_triple_def lex_pair_def 
          abc_step_l.simps abc_lm_v.simps abc_lm_s.simps split: if_splits)
    note r1 r2
  }
  thus ?thesis by auto
qed

lemma  addition_correct': 
  "m  n; max m n < p; length lm > p; lm ! p = 0  
   stp. (λ (as, lm'). as = 7  addition_inv (as, lm') m n p lm) 
                        (abc_steps_l (0, lm) (addition m n p) stp)"
  apply(insert halt_lemma2[of addition_LE
        "λ ((as, lm'), m, p). addition_inv (as, lm') m n p lm"
        "λ stp. (abc_steps_l (0, lm) (addition m n p) stp, m, p)"
        "λ ((as, lm'), m, p). as = 7"], 
      simp add: abc_steps_zero addition_inv_init)
  apply(drule_tac addition_halt_lemma,force,force)
  apply (simp,erule_tac exE)
  apply(rename_tac na)
  apply(rule_tac x = na in exI)
  apply(auto)
  done

lemma length_addition[simp]: "length (addition a b c) = 7"
  by(auto simp: addition.simps)

lemma addition_correct:
  assumes "m  n" "max m n < p" "length lm > p" "lm ! p = 0"
  shows "{λ a. a = lm} (addition m n p) {λ nl. addition_inv (7, nl) m n p lm}"
  using assms
proof(rule_tac abc_Hoare_haltI, simp)
  fix lma
  assume "m  n" "m < p  n < p" "p < length lm" "lm ! p = 0"
  then have " stp. (λ (as, lm'). as = 7  addition_inv (as, lm') m n p lm) 
                        (abc_steps_l (0, lm) (addition m n p) stp)"
    by(rule_tac addition_correct', auto simp: addition_inv.simps)
  then obtain stp where "(λ (as, lm'). as = 7  addition_inv (as, lm') m n p lm) 
                        (abc_steps_l (0, lm) (addition m n p) stp)"
    using exE by presburger
  thus "na. abc_final (abc_steps_l (0, lm) (addition m n p) na) (addition m n p) 
                  (λnl. addition_inv (7, nl) m n p lm) abc_holds_for abc_steps_l (0, lm) (addition m n p) na"
    by(auto intro:exI[of _ stp])
qed

lemma compile_s_correct':
  "{λnl. nl = n # 0  2 @ anything} addition 0 (Suc 0) 2 [+] [Inc (Suc 0)] {λnl. nl = n # Suc n # 0 # anything}"
proof(rule_tac abc_Hoare_plus_halt)
  show "{λnl. nl = n # 0  2 @ anything} addition 0 (Suc 0) 2 {λ nl. addition_inv (7, nl) 0 (Suc 0) 2 (n # 0  2 @ anything)}"
    by(rule_tac addition_correct, auto simp: numeral_2_eq_2)
next
  show "{λnl. addition_inv (7, nl) 0 (Suc 0) 2 (n # 0  2 @ anything)} [Inc (Suc 0)] {λnl. nl = n # Suc n # 0 # anything}"
    by(rule_tac abc_Hoare_haltI, rule_tac x = 1 in exI, auto simp: addition_inv.simps 
        abc_steps_l.simps abc_step_l.simps abc_fetch.simps numeral_2_eq_2 abc_lm_s.simps abc_lm_v.simps)
qed

declare rec_exec.simps[simp del]

lemma abc_comp_commute: "(A [+] B) [+] C = A [+] (B [+] C)"
  apply(auto simp: abc_comp.simps abc_shift.simps)
  apply(rename_tac x)
  apply(case_tac x, auto)
  done



lemma compile_z_correct: 
  "rec_ci z = (ap, arity, fp); rec_exec z [n] = r  
  {λnl. nl = n # 0  (fp - arity) @ anything} ap {λnl. nl = n # r # 0  (fp - Suc arity) @ anything}"
  apply(rule_tac abc_Hoare_haltI)
  apply(rule_tac x = 1 in exI)
  apply(auto simp: abc_steps_l.simps rec_ci.simps rec_ci_z_def 
      numeral_2_eq_2 abc_fetch.simps abc_step_l.simps rec_exec.simps)
  done

lemma compile_s_correct: 
  "rec_ci s = (ap, arity, fp); rec_exec s [n] = r  
  {λnl. nl = n # 0  (fp - arity) @ anything} ap {λnl. nl = n # r # 0  (fp - Suc arity) @ anything}"
  apply(auto simp: rec_ci.simps rec_ci_s_def compile_s_correct' rec_exec.simps)
  done

lemma compile_id_correct':
  assumes "n < length args" 
  shows "{λnl. nl = args @ 0  2 @ anything} addition n (length args) (Suc (length args))
  {λnl. nl = args @ rec_exec (recf.id (length args) n) args # 0 # anything}"
proof -
  have "{λnl. nl = args @ 0  2 @ anything} addition n (length args) (Suc (length args))
  {λnl. addition_inv (7, nl) n (length args) (Suc (length args)) (args @ 0  2 @ anything)}"
    using assms
    by(rule_tac addition_correct, auto simp: numeral_2_eq_2 nth_append)
  thus "?thesis"
    using assms
    by(simp add: addition_inv.simps rec_exec.simps 
        nth_append numeral_2_eq_2 list_update_append)
qed

lemma compile_id_correct: 
  "n < m; length xs = m; rec_ci (recf.id m n) = (ap, arity, fp); rec_exec (recf.id m n) xs = r
        {λnl. nl = xs @ 0  (fp - arity) @ anything} ap {λnl. nl = xs @ r # 0  (fp - Suc arity) @ anything}"
  apply(auto simp: rec_ci.simps rec_ci_id.simps compile_id_correct')
  done

lemma cn_merge_gs_tl_app: 
  "cn_merge_gs (gs @ [g]) pstr = 
        cn_merge_gs gs pstr [+] cn_merge_gs [g] (pstr + length gs)"
  apply(induct gs arbitrary: pstr, simp add: cn_merge_gs.simps, auto)
  apply(simp add: abc_comp_commute)
  done

lemma footprint_ge: 
  "rec_ci a = (p, arity, fp)  arity < fp"
proof(induct a)
  case (Cn x1 a x3)
  then show ?case by(cases "rec_ci a", auto simp:rec_ci.simps)
next
  case (Pr x1 a1 a2)
  then show ?case by(cases "rec_ci a1";cases "rec_ci a2", auto simp:rec_ci.simps)
next
  case (Mn x1 a)
  then show ?case by(cases "rec_ci a", auto simp:rec_ci.simps)
qed (auto simp: rec_ci.simps)

lemma param_pattern: 
  "terminate f xs; rec_ci f = (p, arity, fp)  length xs = arity"
proof(induct arbitrary: p arity fp rule: terminate.induct)
  case (termi_cn f xs gs n) thus ?case 
    by(cases "rec_ci f", (auto simp: rec_ci.simps))
next
  case (termi_pr x g xs n f) thus ?case 
    by (cases "rec_ci f", cases "rec_ci g", auto simp: rec_ci.simps)
next
  case (termi_mn xs n f r) thus ?case 
    by (cases "rec_ci f", auto simp: rec_ci.simps)
qed (auto simp: rec_ci.simps)

lemma replicate_merge_anywhere: 
  "xa @ xb @ ys = x(a+b) @ ys"
  by(simp add:replicate_add)

fun mv_box_inv :: "nat × nat list  nat  nat  nat list  bool"
  where
    "mv_box_inv (as, lm) m n initlm = 
         (let plus = initlm ! m + initlm ! n in
           length initlm > max m n  m  n  
              (if as = 0 then  k l. lm = initlm[m := k, n := l]  
                    k + l = plus  k  initlm ! m 
              else if as = 1 then  k l. lm = initlm[m := k, n := l]
                              k + l + 1 = plus  k < initlm ! m 
              else if as = 2 then  k l. lm = initlm[m := k, n := l] 
                               k + l = plus  k  initlm ! m
              else if as = 3 then lm = initlm[m := 0, n := plus]
              else False))"

fun mv_box_stage1 :: "nat × nat list  nat  nat"
  where
    "mv_box_stage1 (as, lm) m  = 
            (if as = 3 then 0 
             else 1)"

fun mv_box_stage2 :: "nat × nat list  nat  nat"
  where
    "mv_box_stage2 (as, lm) m = (lm ! m)"

fun mv_box_stage3 :: "nat × nat list  nat  nat"
  where
    "mv_box_stage3 (as, lm) m = (if as = 1 then 3 
                                else if as = 2 then 2
                                else if as = 0 then 1 
                                else 0)"

fun mv_box_measure :: "((nat × nat list) × nat)  (nat × nat × nat)"
  where
    "mv_box_measure ((as, lm), m) = 
     (mv_box_stage1 (as, lm) m, mv_box_stage2 (as, lm) m,
      mv_box_stage3 (as, lm) m)"

definition lex_pair :: "((nat × nat) × nat × nat) set"
  where
    "lex_pair = less_than <*lex*> less_than"

definition lex_triple :: 
  "((nat × (nat × nat)) × (nat × (nat × nat))) set"
  where
    "lex_triple  less_than <*lex*> lex_pair"

definition mv_box_LE :: 
  "(((nat × nat list) × nat) × ((nat × nat list) × nat)) set"
  where 
    "mv_box_LE  (inv_image lex_triple mv_box_measure)"

lemma wf_lex_triple: "wf lex_triple"
  by (auto simp:lex_triple_def lex_pair_def)

lemma wf_mv_box_le[intro]: "wf mv_box_LE"
  by(auto intro:wf_lex_triple simp: mv_box_LE_def)

declare mv_box_inv.simps[simp del]

lemma mv_box_inv_init:  
  "m < length initlm; n < length initlm; m  n  
  mv_box_inv (0, initlm) m n initlm"
  apply(simp add: abc_steps_l.simps mv_box_inv.simps)
  apply(rule_tac x = "initlm ! m" in exI, 
      rule_tac x = "initlm ! n" in exI, simp)
  done

lemma abc_fetch[simp]:
  "abc_fetch 0 (mv_box m n) = Some (Dec m 3)"
  "abc_fetch (Suc 0) (mv_box m n) = Some (Inc n)"
  "abc_fetch 2 (mv_box m n) = Some (Goto 0)"
  "abc_fetch 3 (mv_box m n) = None"
     apply(simp_all add: mv_box.simps abc_fetch.simps)
  done

lemma replicate_Suc_iff_anywhere: "x # xb @ ys = x(Suc b) @ ys"
  by simp

lemma exists_smaller_in_list0[simp]: 
  "m  n; m < length initlm; n < length initlm;
    k + l = initlm ! m + initlm ! n; k  initlm ! m; 0 < k
  ka la. initlm[m := k, n := l, m := k - Suc 0] = 
     initlm[m := ka, n := la] 
     Suc (ka + la) = initlm ! m + initlm ! n  
     ka < initlm ! m"
  apply(rule_tac x = "k - Suc 0" in exI, rule_tac x = l in exI, auto)
  apply(subgoal_tac 
      "initlm[m := k, n := l, m := k - Suc 0] = 
       initlm[n := l, m := k, m := k - Suc 0]",force intro:list_update_swap)
  by(simp add: list_update_swap)

lemma exists_smaller_in_list1[simp]:
  "m  n; m < length initlm; n < length initlm; 
    Suc (k + l) = initlm ! m + initlm ! n;
    k < initlm ! m
     ka la. initlm[m := k, n := l, n := Suc l] = 
                initlm[m := ka, n := la]  
                ka + la = initlm ! m + initlm ! n  
                ka  initlm ! m"
  apply(rule_tac x = k in exI, rule_tac x = "Suc l" in exI, auto)
  done

lemma abc_steps_prop[simp]: 
  "length initlm > max m n; m  n  
   ¬ (λ(as, lm) m. as = 3) 
    (abc_steps_l (0, initlm) (mv_box m n) na) m  
  mv_box_inv (abc_steps_l (0, initlm) 
           (mv_box m n) na) m n initlm 
  mv_box_inv (abc_steps_l (0, initlm) 
           (mv_box m n) (Suc na)) m n initlm 
  ((abc_steps_l (0, initlm) (mv_box m n) (Suc na), m),
   abc_steps_l (0, initlm) (mv_box m n) na, m)  mv_box_LE"
  apply(rule impI, simp add: abc_step_red2)
  apply(cases "(abc_steps_l (0, initlm) (mv_box m n) na)",
      simp)
  apply(auto split:if_splits simp add:abc_steps_l.simps mv_box_inv.simps)
       apply(auto simp add: mv_box_LE_def lex_triple_def lex_pair_def 
      abc_step_l.simps abc_steps_l.simps
      mv_box_inv.simps abc_lm_v.simps abc_lm_s.simps
      split: if_splits )
  apply(rule_tac x = k in exI, rule_tac x = "Suc l" in exI, simp)
  done

lemma mv_box_inv_halt: 
  "length initlm > max m n; m  n  
   stp. (λ (as, lm). as = 3  
  mv_box_inv (as, lm) m n initlm) 
             (abc_steps_l (0::nat, initlm) (mv_box m n) stp)"
  apply(insert halt_lemma2[of mv_box_LE
        "λ ((as, lm), m). mv_box_inv (as, lm) m n initlm"
        "λ stp. (abc_steps_l (0, initlm) (mv_box m n) stp, m)"
        "λ ((as, lm), m). as = (3::nat)"
        ])
  apply(insert wf_mv_box_le)
  apply(simp add: mv_box_inv_init abc_steps_zero)
  apply(erule_tac exE)
  by (metis (no_types, lifting) case_prodE' case_prodI)

lemma mv_box_halt_cond:
  "m  n; mv_box_inv (a, b) m n lm; a = 3  
  b = lm[n := lm ! m + lm ! n, m := 0]"
  apply(simp add: mv_box_inv.simps, auto)
  apply(simp add: list_update_swap)
  done

lemma mv_box_correct':
  "length lm > max m n; m  n  
   stp. abc_steps_l (0::nat, lm) (mv_box m n) stp
  = (3, (lm[n := (lm ! m + lm ! n)])[m := 0::nat])"
  by(drule mv_box_inv_halt, auto dest:mv_box_halt_cond)

lemma length_mvbox[simp]: "length (mv_box m n) = 3"
  by(simp add: mv_box.simps)

lemma mv_box_correct: 
  "length lm > max m n; mn 
   {λ nl. nl = lm} mv_box m n {λ nl. nl = lm[n := (lm ! m + lm ! n), m:=0]}"
  apply(drule_tac mv_box_correct', simp)
  apply(auto simp: abc_Hoare_halt_def)
  by (metis abc_final.simps abc_holds_for.simps length_mvbox)

declare list_update.simps(2)[simp del]

lemma zero_case_rec_exec[simp]:
  "length xs < gf; gf  ft; n < length gs
   (rec_exec (gs ! n) xs # 0  (ft - Suc (length xs)) @ map (λi. rec_exec i xs) (take n gs) @ 0  (length gs - n) @ 0 # 0  length xs @ anything)
  [ft + n - length xs := rec_exec (gs ! n) xs, 0 := 0] =
  0  (ft - length xs) @ map (λi. rec_exec i xs) (take n gs) @ rec_exec (gs ! n) xs # 0  (length gs - Suc n) @ 0 # 0  length xs @ anything"
  using list_update_append[of "rec_exec (gs ! n) xs # 0  (ft - Suc (length xs)) @ map (λi. rec_exec i xs) (take n gs)"
      "0  (length gs - n) @ 0 # 0  length xs @ anything" "ft + n - length xs" "rec_exec (gs ! n) xs"]
  apply(auto)
  apply(cases "length gs - n", simp, simp add: list_update.simps replicate_Suc_iff_anywhere Suc_diff_Suc del: replicate_Suc)
  apply(simp add: list_update.simps)
  done

lemma compile_cn_gs_correct':
  assumes
    g_cond: "gset (take n gs). terminate g xs 
  (x xa xb. rec_ci g = (x, xa, xb)  (xc. {λnl. nl = xs @ 0  (xb - xa) @ xc} x {λnl. nl = xs @ rec_exec g xs # 0  (xb - Suc xa) @ xc}))"
    and ft: "ft = max (Suc (length xs)) (Max (insert ffp ((λ(aprog, p, n). n) ` rec_ci ` set gs)))"
  shows 
    "{λnl. nl = xs @ 0 # 0  (ft + length gs) @ anything}
    cn_merge_gs (map rec_ci (take n gs)) ft
  {λnl. nl = xs @ 0  (ft - length xs) @
                    map (λi. rec_exec i xs) (take n gs) @ 0(length gs - n) @ 0  Suc (length xs) @ anything}"
  using g_cond
proof(induct n)
  case 0
  have "ft > length xs"
    using ft
    by simp
  thus "?case"
    apply(rule_tac abc_Hoare_haltI)
    apply(rule_tac x = 0 in exI, simp add: abc_steps_l.simps replicate_add[THEN sym] 
        replicate_Suc[THEN sym] del: replicate_Suc)
    done
next
  case (Suc n)
  have ind': "gset (take n gs).
     terminate g xs  (x xa xb. rec_ci g = (x, xa, xb)  
    (xc. {λnl. nl = xs @ 0  (xb - xa) @ xc} x {λnl. nl = xs @ rec_exec g xs # 0  (xb - Suc xa) @ xc})) 
    {λnl. nl = xs @ 0 # 0  (ft + length gs) @ anything} cn_merge_gs (map rec_ci (take n gs)) ft 
    {λnl. nl = xs @ 0  (ft - length xs) @ map (λi. rec_exec i xs) (take n gs) @ 0  (length gs - n) @ 0  Suc (length xs) @ anything}"
    by fact
  have g_newcond: "gset (take (Suc n) gs).
     terminate g xs  (x xa xb. rec_ci g = (x, xa, xb)  (xc. {λnl. nl = xs @ 0  (xb - xa) @ xc} x {λnl. nl = xs @ rec_exec g xs # 0  (xb - Suc xa) @ xc}))"
    by fact
  from g_newcond have ind:
    "{λnl. nl = xs @ 0 # 0  (ft + length gs) @ anything} cn_merge_gs (map rec_ci (take n gs)) ft 
    {λnl. nl = xs @ 0  (ft - length xs) @ map (λi. rec_exec i xs) (take n gs) @ 0  (length gs - n) @ 0  Suc (length xs) @ anything}"
    apply(rule_tac ind', rule_tac ballI, erule_tac x = g in ballE, simp_all add: take_Suc)
    by(cases "n < length gs", simp add:take_Suc_conv_app_nth, simp)    
  show "?case"
  proof(cases "n < length gs")
    case True
    have h: "n < length gs" by fact
    thus "?thesis"
    proof(simp add: take_Suc_conv_app_nth cn_merge_gs_tl_app)
      obtain gp ga gf where a: "rec_ci (gs!n) = (gp, ga, gf)"
        by (metis prod_cases3)
      moreover have "min (length gs) n = n"
        using h by simp
      moreover have 
        "{λnl. nl = xs @ 0 # 0  (ft + length gs) @ anything}
        cn_merge_gs (map rec_ci (take n gs)) ft [+] (gp [+] mv_box ga (ft + n))
        {λnl. nl = xs @ 0  (ft - length xs) @ map (λi. rec_exec i xs) (take n gs) @ 
        rec_exec (gs ! n) xs # 0  (length gs - Suc n) @ 0 # 0  length xs @ anything}"
      proof(rule_tac abc_Hoare_plus_halt)
        show "{λnl. nl = xs @ 0 # 0  (ft + length gs) @ anything} cn_merge_gs (map rec_ci (take n gs)) ft
          {λnl. nl = xs @ 0  (ft - length xs) @ map (λi. rec_exec i xs) (take n gs) @ 0  (length gs - n) @ 0  Suc (length xs) @ anything}"
          using ind by simp
      next
        have x: "gs!n  set (take (Suc n) gs)"
          using h
          by(simp add: take_Suc_conv_app_nth)
        have b: "terminate (gs!n) xs"
          using a g_newcond h x
          by(erule_tac x = "gs!n" in ballE, simp_all)
        hence c: "length xs = ga"
          using a param_pattern by metis  
        have d: "gf > ga" using footprint_ge a by simp
        have e: "ft  gf"
          using ft a h Max_ge image_eqI
          by(simp, rule_tac max.coboundedI2, rule_tac Max_ge, simp, 
              rule_tac insertI2,  
              rule_tac f = "(λ(aprog, p, n). n)" and x = "rec_ci (gs!n)" in image_eqI, simp, 
              rule_tac x = "gs!n" in image_eqI, simp, simp)
        show "{λnl. nl = xs @ 0  (ft - length xs) @ 
          map (λi. rec_exec i xs) (take n gs) @ 0  (length gs - n) @ 0  Suc (length xs) @ anything} gp [+] mv_box ga (ft + n)
          {λnl. nl = xs @ 0  (ft - length xs) @ map (λi. rec_exec i xs) 
          (take n gs) @ rec_exec (gs ! n) xs # 0  (length gs - Suc n) @ 0 # 0  length xs @ anything}"
        proof(rule_tac abc_Hoare_plus_halt)
          show "{λnl. nl = xs @ 0  (ft - length xs) @ map (λi. rec_exec i xs) (take n gs) @ 0  (length gs - n) @ 0  Suc (length xs) @ anything} gp 
                {λnl. nl = xs @ (rec_exec (gs!n) xs) # 0  (ft - Suc (length xs)) @ map (λi. rec_exec i xs) 
                              (take n gs) @  0  (length gs - n) @ 0 # 0  length xs @ anything}"
          proof -
            have 
              "({λnl. nl = xs @ 0  (gf - ga) @ 0(ft - gf)@map (λi. rec_exec i xs) (take n gs) @ 0  (length gs - n) @ 0  Suc (length xs) @ anything} 
            gp {λnl. nl = xs @ (rec_exec (gs!n) xs) # 0  (gf - Suc ga) @ 
              0(ft - gf)@map (λi. rec_exec i xs) (take n gs) @ 0  (length gs - n) @ 0  Suc (length xs) @ anything})"
              using a g_newcond h x
              apply(erule_tac x = "gs!n" in ballE)
               apply(simp, simp)
              done            
            thus "?thesis"
              using a b c d e
              by(simp add: replicate_merge_anywhere)
          qed
        next
          show 
            "{λnl. nl = xs @ rec_exec (gs ! n) xs #
            0  (ft - Suc (length xs)) @ map (λi. rec_exec i xs) (take n gs) @ 0  (length gs - n) @ 0 # 0  length xs @ anything}
            mv_box ga (ft + n)
            {λnl. nl = xs @ 0  (ft - length xs) @ map (λi. rec_exec i xs) (take n gs) @
            rec_exec (gs ! n) xs # 0  (length gs - Suc n) @ 0 # 0  length xs @ anything}"
          proof -
            have "{λnl. nl = xs @ rec_exec (gs ! n) xs # 0  (ft - Suc (length xs)) @
              map (λi. rec_exec i xs) (take n gs) @ 0  (length gs - n) @ 0 # 0  length xs @ anything}
              mv_box ga (ft + n) {λnl. nl = (xs @ rec_exec (gs ! n) xs # 0  (ft - Suc (length xs)) @
              map (λi. rec_exec i xs) (take n gs) @ 0  (length gs - n) @ 0 # 0  length xs @ anything)
              [ft + n := (xs @ rec_exec (gs ! n) xs # 0  (ft - Suc (length xs)) @ map (λi. rec_exec i xs) (take n gs) @ 
              0  (length gs - n) @ 0 # 0  length xs @ anything) ! ga +
              (xs @ rec_exec (gs ! n) xs # 0  (ft - Suc (length xs)) @ 
              map (λi. rec_exec i xs) (take n gs) @ 0  (length gs - n) @ 0 # 0  length xs @ anything) !
                      (ft + n),  ga := 0]}"
              using a c d e h
              apply(rule_tac mv_box_correct)
               apply(simp, arith, arith)
              done
            moreover have "(xs @ rec_exec (gs ! n) xs # 0  (ft - Suc (length xs)) @
              map (λi. rec_exec i xs) (take n gs) @ 0  (length gs - n) @ 0 # 0  length xs @ anything)
              [ft + n := (xs @ rec_exec (gs ! n) xs # 0  (ft - Suc (length xs)) @ map (λi. rec_exec i xs) (take n gs) @ 
              0  (length gs - n) @ 0 # 0  length xs @ anything) ! ga +
              (xs @ rec_exec (gs ! n) xs # 0  (ft - Suc (length xs)) @ 
              map (λi. rec_exec i xs) (take n gs) @ 0  (length gs - n) @ 0 # 0  length xs @ anything) !
                      (ft + n),  ga := 0]= 
              xs @ 0  (ft - length xs) @ map (λi. rec_exec i xs) (take n gs) @ rec_exec (gs ! n) xs # 0  (length gs - Suc n) @ 0 # 0  length xs @ anything"
              using a c d e h
              by(simp add: list_update_append nth_append length_replicate split: if_splits del: list_update.simps(2), auto)
            ultimately show "?thesis"
              by(simp)
          qed
        qed  
      qed
      ultimately show 
        "{λnl. nl = xs @ 0 # 0  (ft + length gs) @ anything}
        cn_merge_gs (map rec_ci (take n gs)) ft [+] (case rec_ci (gs ! n) of (gprog, gpara, gn) 
        gprog [+] mv_box gpara (ft + min (length gs) n))
        {λnl. nl = xs @ 0  (ft - length xs) @ map (λi. rec_exec i xs) (take n gs) @ rec_exec (gs ! n) xs # 0  (length gs - Suc n) @ 0 # 0  length xs @ anything}"
        by simp
    qed
  next
    case False
    have h: "¬ n < length gs" by fact
    hence ind': 
      "{λnl. nl = xs @ 0 # 0  (ft + length gs) @ anything} cn_merge_gs (map rec_ci gs) ft
        {λnl. nl = xs @ 0  (ft - length xs) @ map (λi. rec_exec i xs) gs @ 0  Suc (length xs) @ anything}"
      using ind
      by simp
    thus "?thesis"
      using h
      by(simp)
  qed
qed

lemma compile_cn_gs_correct:
  assumes
    g_cond: "gset gs. terminate g xs 
  (x xa xb. rec_ci g = (x, xa, xb)  (xc. {λnl. nl = xs @ 0  (xb - xa) @ xc} x {λnl. nl = xs @ rec_exec g xs # 0  (xb - Suc xa) @ xc}))"
    and ft: "ft = max (Suc (length xs)) (Max (insert ffp ((λ(aprog, p, n). n) ` rec_ci ` set gs)))"
  shows 
    "{λnl. nl = xs @ 0 # 0  (ft + length gs) @ anything}
    cn_merge_gs (map rec_ci gs) ft
  {λnl. nl = xs @ 0  (ft - length xs) @
                    map (λi. rec_exec i xs) gs @ 0  Suc (length xs) @ anything}"
  using assms
  using compile_cn_gs_correct'[of "length gs" gs xs ft ffp anything ]
  apply(auto)
  done

lemma length_mvboxes[simp]: "length (mv_boxes aa ba n) = 3*n"
  by(induct n, auto simp: mv_boxes.simps)

lemma exp_suc: "aSuc b = ab @ [a]"
  by(simp add: exp_ind del: replicate.simps)

lemma last_0[simp]: 
  "Suc n  ba - aa;  length lm2 = Suc n;
    length lm3 = ba - Suc (aa + n)
   (last lm2 # lm3 @ butlast lm2 @ 0 # lm4) ! (ba - aa) = (0::nat)"
proof -
  assume h: "Suc n  ba - aa"
    and g: "length lm2 = Suc n" "length lm3 = ba - Suc (aa + n)"
  from h and g have k: "ba - aa = Suc (length lm3 + n)"
    by arith
  from  k show 
    "(last lm2 # lm3 @ butlast lm2 @ 0 # lm4) ! (ba - aa) = 0"
    apply(simp, insert g)
    apply(simp add: nth_append)
    done
qed

lemma butlast_last[simp]: "length lm1 = aa 
      (lm1 @ 0n @ last lm2 # lm3 @ butlast lm2 @ 0 # lm4) ! (aa + n) = last lm2"
  apply(simp add: nth_append)
  done

lemma arith_as_simp[simp]: "Suc n  ba - aa; aa < ba  
                    (ba < Suc (aa + (ba - Suc (aa + n) + n))) = False"
  apply arith
  done

lemma butlast_elem[simp]: "Suc n  ba - aa; aa < ba; length lm1 = aa; 
       length lm2 = Suc n; length lm3 = ba - Suc (aa + n)
      (lm1 @ 0n @ last lm2 # lm3 @ butlast lm2 @ 0 # lm4) ! (ba + n) = 0"
  using nth_append[of "lm1 @ (0::'a)n @ last lm2 # lm3 @ butlast lm2" 
      "(0::'a) # lm4" "ba + n"]
  apply(simp)
  done

lemma update_butlast_eq0[simp]: 
  "Suc n  ba - aa; aa < ba; length lm1 = aa; length lm2 = Suc n;
                 length lm3 = ba - Suc (aa + n)
   (lm1 @ 0n @ last lm2 # lm3 @ butlast lm2 @ (0::nat) # lm4)
  [ba + n := last lm2, aa + n := 0] = 
  lm1 @ 0 # 0n @ lm3 @ lm2 @ lm4"
  using list_update_append[of "lm1 @ 0n @ last lm2 # lm3 @ butlast lm2" "0 # lm4" 
      "ba + n" "last lm2"]
  apply(simp add: list_update_append list_update.simps(2-) replicate_Suc_iff_anywhere exp_suc
      del: replicate_Suc)
  apply(cases lm2, simp, simp)
  done

lemma update_butlast_eq1[simp]:
  "Suc (length lm1 + n)  ba; length lm2 = Suc n; length lm3 = ba - Suc (length lm1 + n); 
  ¬ ba - Suc (length lm1) < ba - Suc (length lm1 + n); ¬ ba + n - length lm1 < n
     (0::nat)  n @ (last lm2 # lm3 @ butlast lm2 @ 0 # lm4)[ba - length lm1 := last lm2, 0 := 0] =
  0 # 0  n @ lm3 @ lm2 @ lm4"
  apply(subgoal_tac "ba - length lm1 = Suc n + length lm3", simp add: list_update.simps(2-) list_update_append)
   apply(simp add: replicate_Suc_iff_anywhere exp_suc del: replicate_Suc)
   apply(cases lm2, simp, simp)
  apply(auto)
  done

lemma mv_boxes_correct: 
  "aa + n  ba; ba > aa; length lm1 = aa; length lm2 = n; length lm3 = ba - aa - n
  {λ nl. nl = lm1 @ lm2 @ lm3 @ 0n @ lm4} (mv_boxes aa ba n) 
     {λ nl. nl = lm1 @ 0n @ lm3 @ lm2 @ lm4}"
proof(induct n arbitrary: lm2 lm3 lm4)
  case 0
  thus "?case"
    by(simp add: mv_boxes.simps abc_Hoare_halt_def, rule_tac  x = 0 in exI, simp add: abc_steps_l.simps)
next
  case (Suc n)
  have ind: 
    "lm2 lm3 lm4.
    aa + n  ba; aa < ba; length lm1 = aa; length lm2 = n; length lm3 = ba - aa - n
     {λnl. nl = lm1 @ lm2 @ lm3 @ 0  n @ lm4} mv_boxes aa ba n {λnl. nl = lm1 @ 0  n @ lm3 @ lm2 @ lm4}"
    by fact
  have h1: "aa + Suc n  ba"  by fact
  have h2: "aa < ba" by fact
  have h3: "length lm1 = aa" by fact
  have h4: "length lm2 = Suc n" by fact 
  have h5: "length lm3 = ba - aa - Suc n" by fact
  have "{λnl. nl = lm1 @ lm2 @ lm3 @ 0  Suc n @ lm4} mv_boxes aa ba n [+] mv_box (aa + n) (ba + n)
    {λnl. nl = lm1 @ 0  Suc n @ lm3 @ lm2 @ lm4}"
  proof(rule_tac abc_Hoare_plus_halt)
    have "{λnl. nl = lm1 @ butlast lm2 @ (last lm2 # lm3) @ 0  n @ (0 # lm4)} mv_boxes aa ba n
          {λ nl. nl = lm1 @ 0n @ (last lm2 # lm3) @ butlast lm2 @ (0 # lm4)}"
      using h1 h2 h3 h4 h5
      by(rule_tac ind, simp_all)
    moreover have " lm1 @ butlast lm2 @ (last lm2 # lm3) @ 0  n @ (0 # lm4)
                  = lm1 @ lm2 @ lm3 @ 0  Suc n @ lm4"
      using h4
      by(simp add: replicate_Suc[THEN sym] exp_suc del: replicate_Suc, 
          cases lm2, simp_all)
    ultimately show "{λnl. nl = lm1 @ lm2 @ lm3 @ 0  Suc n @ lm4} mv_boxes aa ba n
          {λ nl. nl = lm1 @ 0n @ last lm2 # lm3 @ butlast lm2 @ 0 # lm4}"
      by (metis append_Cons)
  next
    let ?lm = "lm1 @ 0  n @ last lm2 # lm3 @ butlast lm2 @ 0 # lm4"
    have "{λnl. nl = ?lm} mv_box (aa + n) (ba + n)
          {λ nl. nl = ?lm[(ba + n) := ?lm!(aa+n) + ?lm!(ba+n), (aa+n):=0]}"
      using h1 h2 h3 h4  h5
      by(rule_tac mv_box_correct, simp_all)
    moreover have "?lm[(ba + n) := ?lm!(aa+n) + ?lm!(ba+n), (aa+n):=0]
                 =  lm1 @ 0  Suc n @ lm3 @ lm2 @ lm4"
      using h1 h2 h3 h4 h5
      by(auto simp: nth_append list_update_append split: if_splits)
    ultimately show "{λnl. nl = lm1 @ 0  n @ last lm2 # lm3 @ butlast lm2 @ 0 # lm4} mv_box (aa + n) (ba + n)
          {λnl. nl = lm1 @ 0  Suc n @ lm3 @ lm2 @ lm4}"
      by simp
  qed
  thus "?case"
    by(simp add: mv_boxes.simps)
qed

lemma update_butlast_eq2[simp]:
  "Suc n  aa - length lm1; length lm1 < aa; 
  length lm2 = aa - Suc (length lm1 + n); 
  length lm3 = Suc n; 
  ¬ aa - Suc (length lm1) < aa - Suc (length lm1 + n);
  ¬ aa + n - length lm1 < n
   butlast lm3 @ ((0::nat) # lm2 @ 0  n @ last lm3 # lm4)[0 := last lm3, aa - length lm1 := 0] = lm3 @ lm2 @ 0 # 0  n @ lm4"
  apply(subgoal_tac "aa - length lm1 = length lm2 + Suc n")
   apply(simp add: list_update.simps list_update_append)
   apply(simp add: replicate_Suc[THEN sym] exp_suc del: replicate_Suc)
   apply(cases lm3, simp, simp)
  apply(auto)
  done

lemma mv_boxes_correct2:
  "n  aa - ba; 
    ba < aa; 
    length (lm1::nat list) = ba;
    length (lm2::nat list) = aa - ba - n; 
    length (lm3::nat list) = n
  {λ nl. nl = lm1 @ 0n @ lm2 @ lm3 @ lm4}
                (mv_boxes aa ba n) 
     {λ nl. nl = lm1 @ lm3 @ lm2 @ 0n @ lm4}"
proof(induct n arbitrary: lm2 lm3 lm4)
  case 0
  thus "?case"
    by(simp add: mv_boxes.simps abc_Hoare_halt_def, rule_tac  x = 0 in exI, simp add: abc_steps_l.simps)
next
  case (Suc n)
  have ind:
    "lm2 lm3 lm4.
    n  aa - ba; ba < aa; length lm1 = ba; length lm2 = aa - ba - n; length lm3 = n
     {λnl. nl = lm1 @ 0  n @ lm2 @ lm3 @ lm4} mv_boxes aa ba n {λnl. nl = lm1 @ lm3 @ lm2 @ 0  n @ lm4}"
    by fact
  have h1: "Suc n  aa - ba" by fact
  have h2: "ba < aa" by fact
  have h3: "length lm1 = ba" by fact 
  have h4: "length lm2 = aa - ba - Suc n" by fact
  have h5: "length lm3 = Suc n" by fact
  have "{λnl. nl = lm1 @ 0  Suc n @ lm2 @ lm3 @ lm4}  mv_boxes aa ba n [+] mv_box (aa + n) (ba + n) 
    {λnl. nl = lm1 @ lm3 @ lm2 @ 0  Suc n @ lm4}"
  proof(rule_tac abc_Hoare_plus_halt)
    have "{λ nl. nl = lm1 @ 0  n @ (0 # lm2) @ (butlast lm3) @ (last lm3 # lm4)} mv_boxes aa ba n
           {λ nl. nl = lm1 @ butlast lm3 @ (0 # lm2) @ 0n @ (last lm3 # lm4)}"
      using h1 h2 h3 h4 h5
      by(rule_tac ind, simp_all)
    moreover have "lm1 @ 0  n @ (0 # lm2) @ (butlast lm3) @ (last lm3 # lm4) 
                   = lm1 @ 0  Suc n @ lm2 @ lm3 @ lm4"
      using h5
      by(simp add: replicate_Suc_iff_anywhere exp_suc 
          del: replicate_Suc, cases lm3, simp_all)
    ultimately show "{λnl. nl = lm1 @ 0  Suc n @ lm2 @ lm3 @ lm4} mv_boxes aa ba n
     {λ nl. nl = lm1 @ butlast lm3 @ (0 # lm2) @ 0n @ (last lm3 # lm4)}"
      by metis
  next
    thm mv_box_correct
    let ?lm = "lm1 @ butlast lm3 @ (0 # lm2) @ 0  n @ last lm3 # lm4"
    have "{λnl. nl = ?lm} mv_box (aa + n) (ba + n)
         {λnl. nl = ?lm[ba+n := ?lm!(aa+n)+?lm!(ba+n), (aa+n):=0]}"
      using h1 h2 h3 h4 h5
      by(rule_tac mv_box_correct, simp_all)
    moreover have "?lm[ba+n := ?lm!(aa+n)+?lm!(ba+n), (aa+n):=0]
               = lm1 @ lm3 @ lm2 @ 0  Suc n @ lm4"
      using h1 h2 h3 h4 h5
      by(auto simp: nth_append list_update_append split: if_splits)
    ultimately show "{λnl. nl = lm1 @ butlast lm3 @ (0 # lm2) @ 0  n @ last lm3 # lm4} mv_box (aa + n) (ba + n)
     {λnl. nl = lm1 @ lm3 @ lm2 @ 0  Suc n @ lm4}"
      by simp
  qed
  thus "?case"
    by(simp add: mv_boxes.simps)
qed    

lemma save_paras: 
  "{λnl. nl = xs @ 0  (max (Suc (length xs)) (Max (insert ffp ((λ(aprog, p, n). n) ` rec_ci ` set gs))) - length xs) @
  map (λi. rec_exec i xs) gs @ 0  Suc (length xs) @ anything}
  mv_boxes 0 (Suc (max (Suc (length xs)) (Max (insert ffp ((λ(aprog, p, n). n) ` rec_ci ` set gs))) + length gs)) (length xs)
  {λnl. nl = 0  max (Suc (length xs)) (Max (insert ffp ((λ(aprog, p, n). n) ` rec_ci ` set gs))) @ map (λi. rec_exec i xs) gs @ 0 # xs @ anything}"
proof -
  let ?ft = "max (Suc (length xs)) (Max (insert ffp ((λ(aprog, p, n). n) ` rec_ci ` set gs)))"
  have "{λnl. nl = [] @ xs @ (0(?ft - length xs) @  map (λi. rec_exec i xs) gs @ [0]) @ 
          0  (length xs) @ anything} mv_boxes 0 (Suc ?ft + length gs) (length xs) 
        {λnl. nl = [] @ 0  (length xs) @ (0(?ft - length xs) @  map (λi. rec_exec i xs) gs @ [0]) @ xs @ anything}"
    by(rule_tac mv_boxes_correct, auto)
  thus "?thesis"
    by(simp add: replicate_merge_anywhere)
qed

lemma length_le_max_insert_rec_ci[intro]: 
  "length gs  ffp  length gs  max x1 (Max (insert ffp (x2 ` x3 ` set gs)))"
  apply(rule_tac max.coboundedI2)
  apply(simp add: Max_ge_iff)
  done

lemma restore_new_paras:
  "ffp  length gs 
  {λnl. nl = 0  max (Suc (length xs)) (Max (insert ffp ((λ(aprog, p, n). n) ` rec_ci ` set gs))) @ map (λi. rec_exec i xs) gs @ 0 # xs @ anything}
    mv_boxes (max (Suc (length xs)) (Max (insert ffp ((λ(aprog, p, n). n) ` rec_ci ` set gs)))) 0 (length gs)
  {λnl. nl = map (λi. rec_exec i xs) gs @ 0  max (Suc (length xs)) (Max (insert ffp ((λ(aprog, p, n). n) ` rec_ci ` set gs))) @ 0 # xs @ anything}"
proof -
  let ?ft = "max (Suc (length xs)) (Max (insert ffp ((λ(aprog, p, n). n) ` rec_ci ` set gs)))"
  assume j: "ffp  length gs"
  hence "{λ nl. nl = [] @ 0length gs @ 0(?ft - length gs) @  map (λi. rec_exec i xs) gs @ ((0 # xs) @ anything)}
       mv_boxes ?ft 0 (length gs)
        {λ nl. nl = [] @ map (λi. rec_exec i xs) gs @ 0(?ft - length gs) @ 0length gs @ ((0 # xs) @ anything)}"
    by(rule_tac mv_boxes_correct2, auto)
  moreover have "?ft  length gs"
    using j
    by(auto)
  ultimately show "?thesis"
    using j
    by(simp add: replicate_merge_anywhere le_add_diff_inverse)
qed

lemma le_max_insert[intro]: "ffp  max x0 (Max (insert ffp (x1 ` x2 ` set gs)))"
  by (rule max.coboundedI2) auto

declare max_less_iff_conj[simp del]

lemma save_rs:
  "far = length gs;
  ffp  max (Suc (length xs)) (Max (insert ffp ((λ(aprog, p, n). n) ` rec_ci ` set gs)));
  far < ffp
  {λnl. nl = map (λi. rec_exec i xs) gs @
  rec_exec (Cn (length xs) f gs) xs # 0  max (Suc (length xs))
  (Max (insert ffp ((λ(aprog, p, n). n) ` rec_ci ` set gs))) @ xs @ anything}
    mv_box far (max (Suc (length xs)) (Max (insert ffp ((λ(aprog, p, n). n) ` rec_ci ` set gs))))
    {λnl. nl = map (λi. rec_exec i xs) gs @
               0  (max (Suc (length xs)) (Max (insert ffp ((λ(aprog, p, n). n) ` rec_ci ` set gs))) - length gs) @
               rec_exec (Cn (length xs) f gs) xs # 0  length gs @ xs @ anything}"
proof -
  let ?ft = "max (Suc (length xs)) (Max (insert ffp ((λ(aprog, p, n). n) ` rec_ci ` set gs)))"
  thm mv_box_correct
  let ?lm= " map (λi. rec_exec i xs) gs @ rec_exec (Cn (length xs) f gs) xs # 0  ?ft @ xs @ anything"
  assume h: "far = length gs" "ffp  ?ft" "far < ffp"
  hence "{λ nl. nl = ?lm} mv_box far ?ft {λ nl. nl = ?lm[?ft := ?lm!far + ?lm!?ft, far := 0]}"
    apply(rule_tac mv_box_correct)
    by( auto)  
  moreover have "?lm[?ft := ?lm!far + ?lm!?ft, far := 0]
    = map (λi. rec_exec i xs) gs @
    0  (?ft - length gs) @
    rec_exec (Cn (length xs) f gs) xs # 0  length gs @ xs @ anything"
    using h
    apply(simp add: nth_append)
    using list_update_length[of "map (λi. rec_exec i xs) gs @ rec_exec (Cn (length xs) f gs) xs #
       0  (?ft - Suc (length gs))" 0 "0  length gs @ xs @ anything" "rec_exec (Cn (length xs) f gs) xs"]
    apply(simp add: replicate_merge_anywhere replicate_Suc_iff_anywhere del: replicate_Suc)
    by(simp add: list_update_append list_update.simps replicate_Suc_iff_anywhere del: replicate_Suc)
  ultimately show "?thesis"
    by(simp)
qed

lemma length_empty_boxes[simp]: "length (empty_boxes n) = 2*n"
  apply(induct n, simp, simp)
  done

lemma empty_one_box_correct:
  "{λnl. nl = 0  n @ x # lm} [Dec n 2, Goto 0] {λnl. nl = 0 # 0  n @ lm}"
proof(induct x)
  case 0
  thus "?case"
    by(simp add: abc_Hoare_halt_def, 
        rule_tac x = 1 in exI, simp add: abc_steps_l.simps 
        abc_step_l.simps abc_fetch.simps abc_lm_v.simps nth_append abc_lm_s.simps
        replicate_Suc[THEN sym] exp_suc del: replicate_Suc)
next
  case (Suc x)
  have "{λnl. nl = 0  n @ x # lm} [Dec n 2, Goto 0] {λnl. nl = 0 # 0  n @ lm}"
    by fact
  then obtain stp where "abc_steps_l (0, 0  n @ x # lm) [Dec n 2, Goto 0] stp
                      = (Suc (Suc 0), 0 # 0  n @ lm)"
    apply(auto simp: abc_Hoare_halt_def)
    by (smt abc_final.simps abc_holds_for.elims(2) length_Cons list.size(3))
  moreover have "abc_steps_l (0, 0n @ Suc x # lm) [Dec n 2, Goto 0] (Suc (Suc 0)) 
        = (0,  0  n @ x # lm)"
    by(auto simp: abc_steps_l.simps abc_step_l.simps abc_fetch.simps abc_lm_v.simps
        nth_append abc_lm_s.simps list_update.simps list_update_append)
  ultimately have "abc_steps_l (0, 0n @ Suc x # lm) [Dec n 2, Goto 0] (Suc (Suc 0) + stp) 
                = (Suc (Suc 0), 0 # 0n @ lm)"
    by(simp only: abc_steps_add)
  thus "?case"
    apply(simp add: abc_Hoare_halt_def)
    apply(rule_tac x = "Suc (Suc stp)" in exI, simp)
    done
qed

lemma empty_boxes_correct: 
  "length lm  n 
  {λ nl. nl = lm} empty_boxes n {λ nl. nl = 0n @ drop n lm}"
proof(induct n)
  case 0
  thus "?case"
    by(simp add: empty_boxes.simps abc_Hoare_halt_def, 
        rule_tac x = 0 in exI, simp add: abc_steps_l.simps)
next
  case (Suc n)
  have ind: "n  length lm  {λnl. nl = lm} empty_boxes n {λnl. nl = 0  n @ drop n lm}" by fact
  have h: "Suc n  length lm" by fact
  have "{λnl. nl = lm} empty_boxes n [+] [Dec n 2, Goto 0] {λnl. nl = 0 # 0  n @ drop (Suc n) lm}"
  proof(rule_tac abc_Hoare_plus_halt)
    show "{λnl. nl = lm} empty_boxes n {λnl. nl = 0  n @ drop n lm}"
      using h
      by(rule_tac ind, simp)
  next
    show "{λnl. nl = 0  n @ drop n lm} [Dec n 2, Goto 0] {λnl. nl = 0 # 0  n @ drop (Suc n) lm}"
      using empty_one_box_correct[of n "lm ! n" "drop (Suc n) lm"]
      using h
      by(simp add: Cons_nth_drop_Suc)
  qed
  thus "?case"
    by(simp add: empty_boxes.simps)
qed

lemma insert_dominated[simp]: "length gs  ffp 
    length gs + (max xs (Max (insert ffp (x1 ` x2 ` set gs))) - length gs) =
    max xs (Max (insert ffp (x1 ` x2 ` set gs)))"
  apply(rule_tac le_add_diff_inverse)
  apply(rule_tac max.coboundedI2)
  apply(simp add: Max_ge_iff)
  done


lemma clean_paras: 
  "ffp  length gs 
  {λnl. nl = map (λi. rec_exec i xs) gs @
  0  (max (Suc (length xs)) (Max (insert ffp ((λ(aprog, p, n). n) ` rec_ci ` set gs))) - length gs) @
  rec_exec (Cn (length xs) f gs) xs # 0  length gs @ xs @ anything}
  empty_boxes (length gs)
  {λnl. nl = 0  max (Suc (length xs)) (Max (insert ffp ((λ(aprog, p, n). n) ` rec_ci ` set gs))) @ 
  rec_exec (Cn (length xs) f gs) xs # 0  length gs @ xs @ anything}"
proof-
  let ?ft = "max (Suc (length xs)) (Max (insert ffp ((λ(aprog, p, n). n) ` rec_ci ` set gs)))"
  assume h: "length gs  ffp"
  let ?lm = "map (λi. rec_exec i xs) gs @ 0  (?ft - length gs) @
    rec_exec (Cn (length xs) f gs) xs # 0  length gs @ xs @ anything"
  have "{λ nl. nl = ?lm} empty_boxes (length gs) {λ nl. nl = 0length gs @ drop (length gs) ?lm}"
    by(rule_tac empty_boxes_correct, simp)
  moreover have "0length gs @ drop (length gs) ?lm 
           =  0  ?ft @  rec_exec (Cn (length xs) f gs) xs # 0  length gs @ xs @ anything"
    using h
    by(simp add: replicate_merge_anywhere)
  ultimately show "?thesis"
    by metis
qed


lemma restore_rs:
  "{λnl. nl = 0  max (Suc (length xs)) (Max (insert ffp ((λ(aprog, p, n). n) ` rec_ci ` set gs))) @ 
  rec_exec (Cn (length xs) f gs) xs # 0  length gs @ xs @ anything}
  mv_box (max (Suc (length xs)) (Max (insert ffp ((λ(aprog, p, n). n) ` rec_ci ` set gs)))) (length xs)
  {λnl. nl = 0  length xs @
  rec_exec (Cn (length xs) f gs) xs #
  0  (max (Suc (length xs)) (Max (insert ffp ((λ(aprog, p, n). n) ` rec_ci ` set gs))) - (length xs)) @
  0  length gs @ xs @ anything}"
proof -
  let ?ft = "max (Suc (length xs)) (Max (insert ffp ((λ(aprog, p, n). n) ` rec_ci ` set gs)))"
  let ?lm = "0(length xs) @  0(?ft - (length xs)) @ rec_exec (Cn (length xs) f gs) xs # 0  length gs @ xs @ anything"
  thm mv_box_correct
  have "{λ nl. nl = ?lm} mv_box ?ft (length xs) {λ nl. nl = ?lm[length xs := ?lm!?ft + ?lm!(length xs), ?ft := 0]}"
    by(rule_tac mv_box_correct, simp, simp)
  moreover have "?lm[length xs := ?lm!?ft + ?lm!(length xs), ?ft := 0]
               =  0  length xs @ rec_exec (Cn (length xs) f gs) xs # 0  (?ft - (length xs)) @ 0  length gs @ xs @ anything"
    apply(auto simp: list_update_append nth_append) (* ~ 7 sec *)
    apply(cases ?ft, simp_all add: Suc_diff_le list_update.simps)
    apply(simp add: exp_suc replicate_Suc[THEN sym] del: replicate_Suc)
    done
  ultimately show "?thesis"
    by(simp add: replicate_merge_anywhere)
qed

lemma restore_orgin_paras:
  "{λnl. nl = 0  length xs @
  rec_exec (Cn (length xs) f gs) xs #
  0  (max (Suc (length xs)) (Max (insert ffp ((λ(aprog, p, n). n) ` rec_ci ` set gs))) - length xs) @ 0  length gs @ xs @ anything}
  mv_boxes (Suc (max (Suc (length xs)) (Max (insert ffp ((λ(aprog, p, n). n) ` rec_ci ` set gs))) + length gs)) 0 (length xs)
  {λnl. nl = xs @ rec_exec (Cn (length xs) f gs) xs # 0  
  (max (Suc (length xs)) (Max (insert ffp ((λ(aprog, p, n). n) ` rec_ci ` set gs))) + length gs) @ anything}"
proof -
  let ?ft = "max (Suc (length xs)) (Max (insert ffp ((λ(aprog, p, n). n) ` rec_ci ` set gs)))"
  thm mv_boxes_correct2
  have "{λ nl. nl = [] @ 0(length xs) @ (rec_exec (Cn (length xs) f gs) xs # 0  (?ft - length xs) @ 0  length gs) @ xs @ anything}
        mv_boxes (Suc ?ft + length gs) 0 (length xs)
        {λ nl. nl = [] @ xs @ (rec_exec (Cn (length xs) f gs) xs # 0  (?ft - length xs) @ 0  length gs) @ 0length xs @ anything}"
    by(rule_tac mv_boxes_correct2, auto)
  thus "?thesis"
    by(simp add: replicate_merge_anywhere)
qed

lemma compile_cn_correct':
  assumes f_ind: 
    " anything r. rec_exec f (map (λg. rec_exec g xs) gs) = rec_exec (Cn (length xs) f gs) xs 
  {λnl. nl = map (λg. rec_exec g xs) gs @ 0  (ffp - far) @ anything} fap
                {λnl. nl = map (λg. rec_exec g xs) gs @ rec_exec (Cn (length xs) f gs) xs # 0  (ffp - Suc far) @ anything}"
    and compile: "rec_ci f = (fap, far, ffp)"
    and term_f: "terminate f (map (λg. rec_exec g xs) gs)"
    and g_cond: "gset gs. terminate g xs 
  (x xa xb. rec_ci g = (x, xa, xb)  
  (xc. {λnl. nl = xs @ 0  (xb - xa) @ xc} x {λnl. nl = xs @ rec_exec g xs # 0  (xb - Suc xa) @ xc}))"
  shows 
    "{λnl. nl = xs @ 0 # 0  (max (Suc (length xs)) (Max (insert ffp ((λ(aprog, p, n). n) ` rec_ci ` set gs))) + length gs) @ anything}
  cn_merge_gs (map rec_ci gs) (max (Suc (length xs)) (Max (insert ffp ((λ(aprog, p, n). n) ` rec_ci ` set gs)))) [+]
  (mv_boxes 0 (Suc (max (Suc (length xs)) (Max (insert ffp ((λ(aprog, p, n). n) ` rec_ci ` set gs))) + length gs)) (length xs) [+]
  (mv_boxes (max (Suc (length xs)) (Max (insert ffp ((λ(aprog, p, n). n) ` rec_ci ` set gs)))) 0 (length gs) [+]
  (fap [+] (mv_box far (max (Suc (length xs)) (Max (insert ffp ((λ(aprog, p, n). n) ` rec_ci ` set gs)))) [+]
  (empty_boxes (length gs) [+]
  (mv_box (max (Suc (length xs)) (Max (insert ffp ((λ(aprog, p, n). n) ` rec_ci ` set gs)))) (length xs) [+]
  mv_boxes (Suc (max (Suc (length xs)) (Max (insert ffp ((λ(aprog, p, n). n) ` rec_ci ` set gs))) + length gs)) 0 (length xs)))))))
  {λnl. nl = xs @ rec_exec (Cn (length xs) f gs) xs # 
0  (max (Suc (length xs)) (Max (insert ffp ((λ(aprog, p, n). n) ` rec_ci ` set gs))) + length gs) @ anything}"
proof -
  let ?ft = "max (Suc (length xs)) (Max (insert ffp ((λ(aprog, p, n). n) ` rec_ci ` set gs)))"
  let ?A = "cn_merge_gs (map rec_ci gs) ?ft"
  let ?B = "mv_boxes 0 (Suc (?ft+length gs)) (length xs)"
  let ?C = "mv_boxes ?ft 0 (length gs)"
  let ?D = fap
  let ?E = "mv_box far ?ft"
  let ?F = "empty_boxes (length gs)"
  let ?G = "mv_box ?ft (length xs)"
  let ?H = "mv_boxes (Suc (?ft + length gs)) 0 (length xs)"
  let ?P1 = "λnl. nl = xs @ 0 # 0  (?ft + length gs) @ anything"
  let ?S = "λnl. nl = xs @ rec_exec (Cn (length xs) f gs) xs # 0  (?ft + length gs) @ anything"
  let ?Q1 = "λ nl. nl = xs @ 0(?ft - length xs) @ map (λ i. rec_exec i xs) gs @ 0(Suc (length xs)) @ anything"
  show "{?P1} (?A [+] (?B [+] (?C [+] (?D [+] (?E [+] (?F [+] (?G [+] ?H))))))) {?S}"
  proof(rule_tac abc_Hoare_plus_halt)
    show "{?P1} ?A {?Q1}"
      using g_cond
      by(rule_tac compile_cn_gs_correct, auto)
  next
    let ?Q2 = "λnl. nl = 0  ?ft @
                    map (λi. rec_exec i xs) gs @ 0 # xs @ anything"
    show "{?Q1} (?B [+] (?C [+] (?D [+] (?E [+] (?F [+] (?G [+] ?H)))))) {?S}"
    proof(rule_tac abc_Hoare_plus_halt)
      show "{?Q1} ?B {?Q2}"
        by(rule_tac save_paras)
    next
      let ?Q3 = "λ nl. nl = map (λi. rec_exec i xs) gs @ 0?ft @ 0 # xs @ anything" 
      show "{?Q2} (?C [+] (?D [+] (?E [+] (?F [+] (?G [+] ?H))))) {?S}"
      proof(rule_tac abc_Hoare_plus_halt)
        have "ffp  length gs"
          using compile term_f
          apply(subgoal_tac "length gs = far")
           apply(drule_tac footprint_ge, simp)
          by(drule_tac param_pattern, auto)          
        thus "{?Q2} ?C {?Q3}"
          by(erule_tac restore_new_paras)
      next
        let ?Q4 = "λ nl. nl = map (λi. rec_exec i xs) gs @ rec_exec (Cn (length xs) f gs) xs # 0?ft @ xs @ anything"
        have a: "far = length gs"
          using compile term_f
          by(drule_tac param_pattern, auto)
        have b:"?ft  ffp"
          by auto
        have c: "ffp > far"
          using compile
          by(erule_tac footprint_ge)
        show "{?Q3} (?D [+] (?E [+] (?F [+] (?G [+] ?H)))) {?S}"
        proof(rule_tac abc_Hoare_plus_halt)
          have "{λnl. nl = map (λg. rec_exec g xs) gs @ 0  (ffp - far) @ 0(?ft - ffp + far) @ 0 # xs @ anything} fap
            {λnl. nl = map (λg. rec_exec g xs) gs @ rec_exec (Cn (length xs) f gs) xs # 
            0  (ffp - Suc far) @ 0(?ft - ffp + far) @ 0 # xs @ anything}"
            by(rule_tac f_ind, simp add: rec_exec.simps)
          thus "{?Q3} fap {?Q4}"
            using a b c
            by(simp add: replicate_merge_anywhere,
                cases "?ft", simp_all add: exp_suc del: replicate_Suc)
        next
          let ?Q5 = "λnl. nl = map (λi. rec_exec i xs) gs @
               0(?ft - length gs) @ rec_exec (Cn (length xs) f gs) xs # 0(length gs)@ xs @ anything"
          show "{?Q4} (?E [+] (?F [+] (?G [+] ?H))) {?S}"
          proof(rule_tac abc_Hoare_plus_halt)
            from a b c show "{?Q4} ?E {?Q5}"
              by(erule_tac save_rs, simp_all)
          next
            let ?Q6 = "λnl. nl = 0?ft @ rec_exec (Cn (length xs) f gs) xs # 0(length gs)@ xs @ anything"
            show "{?Q5} (?F [+] (?G [+] ?H)) {?S}"
            proof(rule_tac abc_Hoare_plus_halt)
              have "length gs  ffp" using a b c
                by simp
              thus "{?Q5} ?F {?Q6}"
                by(erule_tac clean_paras)
            next
              let ?Q7 = "λnl. nl = 0length xs @ rec_exec (Cn (length xs) f gs) xs # 0(?ft - (length xs)) @ 0(length gs)@ xs @ anything"
              show "{?Q6} (?G [+] ?H) {?S}"
              proof(rule_tac abc_Hoare_plus_halt)
                show "{?Q6} ?G {?Q7}"
                  by(rule_tac restore_rs)
              next
                show "{?Q7} ?H {?S}"
                  by(rule_tac restore_orgin_paras)
              qed
            qed
          qed
        qed        
      qed
    qed
  qed
qed

lemma compile_cn_correct:
  assumes termi_f: "terminate f (map (λg. rec_exec g xs) gs)"
    and f_ind: "ap arity fp anything.
  rec_ci f = (ap, arity, fp)
   {λnl. nl = map (λg. rec_exec g xs) gs @ 0  (fp - arity) @ anything} ap
  {λnl. nl = map (λg. rec_exec g xs) gs @ rec_exec f (map (λg. rec_exec g xs) gs) # 0  (fp - Suc arity) @ anything}"
    and g_cond: 
    "gset gs. terminate g xs 
  (x xa xb. rec_ci g = (x, xa, xb)    (xc. {λnl. nl = xs @ 0  (xb - xa) @ xc} x {λnl. nl = xs @ rec_exec g xs # 0  (xb - Suc xa) @ xc}))"
    and compile: "rec_ci (Cn n f gs) = (ap, arity, fp)"
    and len: "length xs = n"
  shows "{λnl. nl = xs @ 0  (fp - arity) @ anything} ap {λnl. nl = xs @ rec_exec (Cn n f gs) xs # 0  (fp - Suc arity) @ anything}"
proof(cases "rec_ci f")
  fix fap far ffp
  assume h: "rec_ci f = (fap, far, ffp)"
  then have f_newind: " anything .{λnl. nl = map (λg. rec_exec g xs) gs @ 0  (ffp - far) @ anything} fap
    {λnl. nl = map (λg. rec_exec g xs) gs @ rec_exec f (map (λg. rec_exec g xs) gs) # 0  (ffp - Suc far) @ anything}"
    by(rule_tac f_ind, simp_all)
  thus "{λnl. nl = xs @ 0  (fp - arity) @ anything} ap {λnl. nl = xs @ rec_exec (Cn n f gs) xs # 0  (fp - Suc arity) @ anything}"
    using compile len h termi_f g_cond
    apply(auto simp: rec_ci.simps abc_comp_commute)
    apply(rule_tac compile_cn_correct', simp_all)
    done
qed

lemma mv_box_correct_simp[simp]: 
  "length xs = n; ft = max (n+3) (max fft gft) 
  {λnl. nl = xs @ 0 # 0  (ft - n) @ anything} mv_box n ft 
       {λnl. nl = xs @ 0 # 0  (ft - n) @ anything}"
  using mv_box_correct[of n ft "xs @ 0 # 0  (ft - n) @ anything"]
  by(auto)

lemma length_under_max[simp]: "length xs < max (length xs + 3) fft"
  by auto

lemma save_init_rs: 
  "length xs = n; ft = max (n+3) (max fft gft) 
       {λnl. nl = xs @ rec_exec f xs # 0  (ft - n) @ anything} mv_box n (Suc n) 
       {λnl. nl = xs @ 0 # rec_exec f xs # 0  (ft - Suc n) @ anything}"
  using mv_box_correct[of n "Suc n" "xs @ rec_exec f xs # 0  (ft - n) @ anything"]
  apply(auto simp: list_update_append list_update.simps nth_append split: if_splits)
  apply(cases "(max (length xs + 3) (max fft gft))", simp_all add: list_update.simps Suc_diff_le)
  done

lemma less_then_max_plus2[simp]: "n + (2::nat) < max (n + 3) x"
  by auto

lemma less_then_max_plus3[simp]: "n < max (n + (3::nat)) x"
  by auto

lemma mv_box_max_plus_3_correct[simp]:
  "length xs = n  
  {λnl. nl = xs @ x # 0  (max (n + (3::nat)) (max fft gft) - n) @ anything} mv_box n (max (n + 3) (max fft gft))
  {λnl. nl = xs @ 0  (max (n + 3) (max fft gft) - n) @ x # anything}"
proof -
  assume h: "length xs = n"
  let ?ft = "max (n+3) (max fft gft)"
  let ?lm = "xs @ x # 0(?ft - Suc n) @ 0 # anything"
  have g: "?ft > n + 2"
    by simp
  thm mv_box_correct
  have a: "{λ nl. nl = ?lm} mv_box n ?ft {λ nl. nl = ?lm[?ft := ?lm!n + ?lm!?ft, n := 0]}"
    using h
    by(rule_tac mv_box_correct, auto)
  have b:"?lm = xs @ x # 0  (max (n + 3) (max fft gft) - n) @ anything"
    by(cases ?ft, simp_all add: Suc_diff_le exp_suc del: replicate_Suc)
  have c: "?lm[?ft := ?lm!n + ?lm!?ft, n := 0] = xs @ 0  (max (n + 3) (max fft gft) - n) @ x # anything"
    using h g
    apply(auto simp: nth_append list_update_append split: if_splits)
    using list_update_append[of "x # 0  (max (length xs + 3) (max fft gft) - Suc (length xs))" "0 # anything"
        "max (length xs + 3) (max fft gft) - length xs" "x"]
    apply(auto simp: if_splits)
    apply(simp add: list_update.simps replicate_Suc[THEN sym] del: replicate_Suc)
    done
  from a c show "?thesis"
    using h
    apply(simp)
    using b
    by simp
qed

lemma max_less_suc_suc[simp]: "max n (Suc n) < Suc (Suc (max (n + 3) x + anything - Suc 0))"
  by arith    

lemma suc_less_plus_3[simp]: "Suc n < max (n + 3) x"
  by arith

lemma mv_box_ok_suc_simp[simp]:
  "length xs = n
  {λnl. nl = xs @ rec_exec f xs # 0  (max (n + 3) (max fft gft) - Suc n) @ x # anything} mv_box n (Suc n)
    {λnl. nl = xs @ 0 # rec_exec f xs # 0  (max (n + 3) (max fft gft) - Suc (Suc n)) @ x # anything}"
  using mv_box_correct[of n "Suc n" "xs @ rec_exec f xs # 0  (max (n + 3) (max fft gft) - Suc n) @ x # anything"]
  apply(simp add: nth_append list_update_append list_update.simps)
  apply(cases "max (n + 3) (max fft gft)", simp_all)
  apply(cases "max (n + 3) (max fft gft) - 1", simp_all add: Suc_diff_le list_update.simps(2))
  done

lemma abc_append_frist_steps_eq_pre: 
  assumes notfinal: "abc_notfinal (abc_steps_l (0, lm)  A n) A"
    and notnull: "A  []"
  shows "abc_steps_l (0, lm) (A @ B) n = abc_steps_l (0, lm) A n"
  using notfinal
proof(induct n)
  case 0
  thus "?case"
    by(simp add: abc_steps_l.simps)
next
  case (Suc n)
  have ind: "abc_notfinal (abc_steps_l (0, lm) A n) A  abc_steps_l (0, lm) (A @ B) n = abc_steps_l (0, lm) A n"
    by fact
  have h: "abc_notfinal (abc_steps_l (0, lm) A (Suc n)) A" by fact
  then have a: "abc_notfinal (abc_steps_l (0, lm) A n) A"
    by(simp add: notfinal_Suc)
  then have b: "abc_steps_l (0, lm) (A @ B) n = abc_steps_l (0, lm) A n"
    using ind by simp
  obtain s lm' where c: "abc_steps_l (0, lm) A n = (s, lm')"
    by (metis prod.exhaust)
  then have d: "s < length A  abc_steps_l (0, lm) (A @ B) n = (s, lm')" 
    using a b by simp
  thus "?case"
    using c
    by(simp add: abc_step_red2 abc_fetch.simps abc_step_l.simps nth_append)
qed

lemma abc_append_first_step_eq_pre: 
  "st < length A
  abc_step_l (st, lm) (abc_fetch st (A @ B)) = 
    abc_step_l (st, lm) (abc_fetch st A)"
  by(simp add: abc_step_l.simps abc_fetch.simps nth_append)

lemma abc_append_frist_steps_halt_eq': 
  assumes final: "abc_steps_l (0, lm) A n = (length A, lm')"
    and notnull: "A  []"
  shows " n'. abc_steps_l (0, lm) (A @ B) n' = (length A, lm')"
proof -
  have " n'. abc_notfinal (abc_steps_l (0, lm) A n') A  
    abc_final (abc_steps_l (0, lm) A (Suc n')) A"
    using assms
    by(rule_tac n = n in abc_before_final, simp_all)
  then obtain na where a:
    "abc_notfinal (abc_steps_l (0, lm) A na) A  
            abc_final (abc_steps_l (0, lm) A (Suc na)) A" ..
  obtain sa lma where b: "abc_steps_l (0, lm) A na = (sa, lma)"
    by (metis prod.exhaust)
  then have c: "abc_steps_l (0, lm) (A @ B) na = (sa, lma)"
    using a abc_append_frist_steps_eq_pre[of lm A na B] assms 
    by simp
  have d: "sa < length A" using b a by simp
  then have e: "abc_step_l (sa, lma) (abc_fetch sa (A @ B)) = 
    abc_step_l (sa, lma) (abc_fetch sa A)"
    by(rule_tac abc_append_first_step_eq_pre)
  from a have "abc_steps_l (0, lm) A (Suc na) = (length A, lm')"
    using final equal_when_halt
    by(cases "abc_steps_l (0, lm) A (Suc na)" , simp)
  then have "abc_steps_l (0, lm) (A @ B) (Suc na) = (length A, lm')"
    using a b c e
    by(simp add: abc_step_red2)
  thus "?thesis"
    by blast
qed

lemma abc_append_frist_steps_halt_eq: 
  assumes final: "abc_steps_l (0, lm) A n = (length A, lm')"
  shows " n'. abc_steps_l (0, lm) (A @ B) n' = (length A, lm')"
  using final
  apply(cases "A = []")
   apply(rule_tac x = 0 in exI, simp add: abc_steps_l.simps abc_exec_null)
  apply(rule_tac abc_append_frist_steps_halt_eq', simp_all)
  done

lemma suc_suc_max_simp[simp]: "Suc (Suc (max (xs + 3) fft - Suc (Suc ( xs))))
           = max ( xs + 3) fft - ( xs)"
  by arith

lemma contract_dec_ft_length_plus_7[simp]: "ft = max (n + 3) (max fft gft); length xs = n 
     {λnl. nl = xs @ (x - Suc y) # rec_exec (Pr n f g) (xs @ [x - Suc y]) # 0  (ft - Suc (Suc n)) @ Suc y # anything}
     [Dec ft (length gap + 7)] 
     {λnl. nl = xs @ (x - Suc y) # rec_exec (Pr n f g) (xs @ [x - Suc y]) # 0  (ft - Suc (Suc n)) @ y # anything}"
  apply(simp add: abc_Hoare_halt_def)
  apply(rule_tac x = 1 in exI)
  apply(auto simp: abc_steps_l.simps abc_step_l.simps abc_fetch.simps nth_append 
      abc_lm_v.simps abc_lm_s.simps list_update_append)
  using list_update_length
    [of "(x - Suc y) # rec_exec (Pr (length xs) f g) (xs @ [x - Suc y]) #
          0  (max (length xs + 3) (max fft gft) - Suc (Suc (length xs)))" "Suc y" anything y]
  apply(simp)
  done

lemma adjust_paras': 
  "length xs = n  {λnl. nl = xs @ x # y # anything}  [Inc n] [+] [Dec (Suc n) 2, Goto 0]
       {λnl. nl = xs @ Suc x # 0 # anything}"
proof(rule_tac abc_Hoare_plus_halt)
  assume "length xs = n"
  thus "{λnl. nl = xs @ x # y # anything} [Inc n] {λ nl. nl = xs @ Suc x # y # anything}"
    apply(simp add: abc_Hoare_halt_def)
    apply(rule_tac x = 1 in exI, force simp add: abc_steps_l.simps abc_step_l.simps
        abc_fetch.simps abc_comp.simps
        abc_lm_v.simps abc_lm_s.simps nth_append list_update_append list_update.simps(2))
    done
next
  assume h: "length xs = n"
  thus "{λnl. nl = xs @ Suc x # y # anything} [Dec (Suc n) 2, Goto 0] {λnl. nl = xs @ Suc x # 0 # anything}"
  proof(induct y)
    case 0
    thus "?case"
      apply(simp add: abc_Hoare_halt_def)
      apply(rule_tac x = 1 in exI, simp add: abc_steps_l.simps abc_step_l.simps abc_fetch.simps
          abc_comp.simps
          abc_lm_v.simps abc_lm_s.simps nth_append list_update_append list_update.simps(2))
      done
  next
    case (Suc y)
    have "length xs = n  
      {λnl. nl = xs @ Suc x # y # anything} [Dec (Suc n) 2, Goto 0] {λnl. nl = xs @ Suc x # 0 # anything}" by fact
    then obtain stp where 
      "abc_steps_l (0, xs @ Suc x # y # anything) [Dec (Suc n) 2, Goto 0] stp = (2, xs @ Suc x # 0 # anything)"
      using h
      apply(auto simp: abc_Hoare_halt_def numeral_2_eq_2)
      by (metis (mono_tags, lifting) abc_final.simps abc_holds_for.elims(2) length_Cons list.size(3))
    moreover have "abc_steps_l (0, xs @ Suc x # Suc y # anything) [Dec (Suc n) 2, Goto 0] 2 = 
                 (0, xs @ Suc x # y # anything)"
      using h
      by(simp add: abc_steps_l.simps numeral_2_eq_2 abc_step_l.simps abc_fetch.simps
          abc_lm_v.simps abc_lm_s.simps nth_append list_update_append list_update.simps(2))
    ultimately show "?case"
      apply(simp add: abc_Hoare_halt_def)
      by(rule exI[of _ "2 + stp"], simp only: abc_steps_add, simp)
  qed
qed

lemma adjust_paras: 
  "length xs = n  {λnl. nl = xs @ x # y # anything}  [Inc n, Dec (Suc n) 3, Goto (Suc 0)]
       {λnl. nl = xs @ Suc x # 0 # anything}"
  using adjust_paras'[of xs n x y anything]
  by(simp add: abc_comp.simps abc_shift.simps numeral_2_eq_2 numeral_3_eq_3)

lemma rec_ci_SucSuc_n[simp]: "rec_ci g = (gap, gar, gft); y<x. terminate g (xs @ [y, rec_exec (Pr n f g) (xs @ [y])]);
        length xs = n; Suc yx  gar = Suc (Suc n)"
  by(auto dest:param_pattern elim!:allE[of _ y])

lemma loop_back':  
  assumes h: "length A = length gap + 4" "length xs = n"
    and le: "y  x"
  shows " stp. abc_steps_l (length A, xs @ m # (y - x) # x # anything) (A @ [Dec (Suc (Suc n)) 0, Inc (Suc n), Goto (length gap + 4)]) stp
     = (length A, xs @ m # y # 0 # anything)"
  using le
proof(induct x)
  case 0
  thus "?case"
    using h
    by(rule_tac x = 0 in exI,
        auto simp: abc_steps_l.simps abc_step_l.simps abc_fetch.simps nth_append abc_lm_s.simps abc_lm_v.simps)
next
  case (Suc x)
  have "x  y  stp. abc_steps_l (length A, xs @ m # (y - x) # x # anything) (A @ [Dec (Suc (Suc n)) 0, Inc (Suc n), Goto (length gap + 4)]) stp =
              (length A, xs @ m # y # 0 # anything)" by fact
  moreover have "Suc x  y" by fact
  moreover then have " stp. abc_steps_l (length A, xs @ m # (y - Suc x) # Suc x # anything) (A @ [Dec (Suc (Suc n)) 0, Inc (Suc n), Goto (length gap + 4)]) stp
                = (length A, xs @ m # (y - x) # x # anything)"
    using h
    apply(rule_tac x = 3 in exI)
    by(simp add: abc_steps_l.simps numeral_3_eq_3 abc_step_l.simps abc_fetch.simps nth_append
        abc_lm_v.simps abc_lm_s.simps list_update_append list_update.simps(2))
  ultimately show "?case"
    apply(auto simp add: abc_steps_add)
    by (metis abc_steps_add)
qed


lemma loop_back:  
  assumes h: "length A = length gap + 4" "length xs = n"
  shows " stp. abc_steps_l (length A, xs @ m # 0 # x # anything) (A @ [Dec (Suc (Suc n)) 0, Inc (Suc n), Goto (length gap + 4)]) stp
     = (0, xs @ m # x # 0 # anything)"
  using loop_back'[of A gap xs n x x m anything] assms
  apply(auto) apply(rename_tac stp)
  apply(rule_tac x = "stp + 1" in exI)
  apply(simp only: abc_steps_add, simp)
  apply(simp add: abc_steps_l.simps abc_step_l.simps abc_fetch.simps nth_append abc_lm_v.simps
      abc_lm_s.simps)
  done

lemma rec_exec_pr_0_simps: "rec_exec (Pr n f g) (xs @ [0]) = rec_exec f xs"
  by(simp add: rec_exec.simps)

lemma rec_exec_pr_Suc_simps: "rec_exec (Pr n f g) (xs @ [Suc y])
          = rec_exec g (xs @ [y, rec_exec (Pr n f g) (xs @ [y])])"
  apply(induct y)
   apply(simp add: rec_exec.simps)
  apply(simp add: rec_exec.simps)
  done

lemma suc_max_simp[simp]: "Suc (max (n + 3) fft - Suc (Suc (Suc n))) = max (n + 3) fft - Suc (Suc n)"
  by arith

lemma pr_loop:
  assumes code: "code = ([Dec (max (n + 3) (max fft gft)) (length gap + 7)] [+] (gap [+] [Inc n, Dec (Suc n) 3, Goto (Suc 0)])) @
    [Dec (Suc (Suc n)) 0, Inc (Suc n), Goto (length gap + 4)]"
    and len: "length xs = n"
    and g_ind: " y<x. (anything. {λnl. nl = xs @ y # rec_exec (Pr n f g) (xs @ [y]) # 0  (gft - gar) @ anything} gap
  {λnl. nl = xs @ y # rec_exec (Pr n f g) (xs @ [y]) # rec_exec g (xs @ [y, rec_exec (Pr n f g) (xs @ [y])]) # 0  (gft - Suc gar) @ anything})"
    and compile_g: "rec_ci g = (gap, gar, gft)"
    and termi_g: " y<x. terminate g (xs @ [y, rec_exec (Pr n f g) (xs @ [y])])"
    and ft: "ft = max (n + 3) (max fft gft)"
    and less: "Suc y  x"
  shows 
    "stp. abc_steps_l (0, xs @ (x - Suc y) # rec_exec (Pr n f g) (xs @ [x - Suc y]) # 0  (ft - Suc (Suc n)) @ Suc y # anything)
  code stp = (0, xs @ (x - y) # rec_exec (Pr n f g) (xs @ [x - y]) # 0  (ft - Suc (Suc n)) @ y # anything)"
proof -
  let ?A = "[Dec  ft (length gap + 7)]"
  let ?B = "gap"
  let ?C = "[Inc n, Dec (Suc n) 3, Goto (Suc 0)]"
  let ?D = "[Dec (Suc (Suc n)) 0, Inc (Suc n), Goto (length gap + 4)]"
  have " stp. abc_steps_l (0, xs @ (x - Suc y) # rec_exec (Pr n f g) (xs @ [x - Suc y]) # 0  (ft - Suc (Suc n)) @ Suc y # anything)
            ((?A [+] (?B [+] ?C)) @ ?D) stp = (length (?A [+] (?B [+] ?C)), 
          xs @ (x - y) # 0 # rec_exec g (xs @ [x - Suc y, rec_exec (Pr n f g) (xs @ [x - Suc y])])
                  # 0  (ft - Suc (Suc (Suc n))) @ y # anything)"
  proof -
    have " stp. abc_steps_l (0, xs @ (x - Suc y) # rec_exec (Pr n f g) (xs @ [x - Suc y]) # 0  (ft - Suc (Suc n)) @ Suc y # anything)
      ((?A [+] (?B [+] ?C))) stp = (length (?A [+] (?B [+] ?C)),  xs @ (x - y) # 0 # 
      rec_exec g (xs @ [x - Suc y, rec_exec (Pr n f g) (xs @ [x - Suc y])]) # 0  (ft - Suc (Suc (Suc n))) @ y # anything)"
    proof -
      have "{λ nl. nl = xs @ (x - Suc y) # rec_exec (Pr n f g) (xs @ [x - Suc y]) # 0  (ft - Suc (Suc n)) @ Suc y # anything}
        (?A [+] (?B [+] ?C)) 
        {λ nl. nl = xs @ (x - y) # 0 # 
        rec_exec g (xs @ [x - Suc y, rec_exec (Pr n f g) (xs @ [x - Suc y])]) # 0  (ft - Suc (Suc (Suc n))) @ y # anything}"
      proof(rule_tac abc_Hoare_plus_halt)
        show "{λnl. nl = xs @ (x - Suc y) # rec_exec (Pr n f g) (xs @ [x - Suc y]) # 0  (ft - Suc (Suc n)) @ Suc y # anything}
          [Dec ft (length gap + 7)] 
          {λnl. nl = xs @ (x - Suc y) # rec_exec (Pr n f g) (xs @ [x - Suc y]) # 0  (ft - Suc (Suc n)) @ y # anything}"
          using ft len
          by(simp)
      next
        show 
          "{λnl. nl = xs @ (x - Suc y) # rec_exec (Pr n f g) (xs @ [x - Suc y]) # 0  (ft - Suc (Suc n)) @ y # anything} 
          ?B [+] ?C
          {λnl. nl = xs @ (x - y) # 0 # rec_exec g (xs @ [x - Suc y, rec_exec (Pr n f g) (xs @ [x - Suc y])]) # 0  (ft - Suc (Suc (Suc n))) @ y # anything}"
        proof(rule_tac abc_Hoare_plus_halt)
          have a: "gar = Suc (Suc n)" 
            using compile_g termi_g len less
            by simp
          have b: "gft > gar"
            using compile_g
            by(erule_tac footprint_ge)
          show "{λnl. nl = xs @ (x - Suc y) # rec_exec (Pr n f g) (xs @ [x - Suc y]) # 0  (ft - Suc (Suc n)) @ y # anything} gap 
                {λnl. nl = xs @ (x - Suc y) # rec_exec (Pr n f g) (xs @ [x - Suc y]) # 
                      rec_exec g (xs @ [x - Suc y, rec_exec (Pr n f g) (xs @ [x - Suc y])]) # 0  (ft - Suc (Suc (Suc n))) @ y # anything}"
          proof -
            have 
              "{λnl. nl = xs @ (x - Suc y) # rec_exec (Pr n f g) (xs @ [x - Suc y]) # 0  (gft - gar) @ 0(ft - gft) @ y # anything} gap
              {λnl. nl = xs @ (x - Suc y) # rec_exec (Pr n f g) (xs @ [x - Suc y]) # 
              rec_exec g (xs @ [(x - Suc y), rec_exec (Pr n f g) (xs @ [x - Suc y])]) # 0  (gft - Suc gar) @ 0(ft - gft) @ y # anything}"
              using g_ind less by simp
            thus "?thesis"
              using a b ft
              by(simp add: replicate_merge_anywhere numeral_3_eq_3)
          qed
        next
          show "{λnl. nl = xs @ (x - Suc y) #
                    rec_exec (Pr n f g) (xs @ [x - Suc y]) #
            rec_exec g (xs @ [x - Suc y, rec_exec (Pr n f g) (xs @ [x - Suc y])]) # 0  (ft - Suc (Suc (Suc n))) @ y # anything}
            [Inc n, Dec (Suc n) 3, Goto (Suc 0)]
            {λnl. nl = xs @ (x - y) # 0 # rec_exec g (xs @ [x - Suc y, rec_exec (Pr n f g) 
                    (xs @ [x - Suc y])]) # 0  (ft - Suc (Suc (Suc n))) @ y # anything}"
            using len less
            using adjust_paras[of xs n "x - Suc y" " rec_exec (Pr n f g) (xs @ [x - Suc y])"
                " rec_exec g (xs @ [x - Suc y, rec_exec (Pr n f g) (xs @ [x - Suc y])]) # 
              0  (ft - Suc (Suc (Suc n))) @ y # anything"]
            by(simp add: Suc_diff_Suc)
        qed
      qed
      thus "?thesis"
        apply(simp add: abc_Hoare_halt_def, auto)
        apply(rename_tac na)
        apply(rule_tac x = na in exI, case_tac "abc_steps_l (0, xs @ (x - Suc y) # rec_exec (Pr n f g) (xs @ [x - Suc y]) # 
          0  (ft - Suc (Suc n)) @ Suc y # anything)
             ([Dec ft (length gap + 7)] [+] (gap [+] [Inc n, Dec (Suc n) 3, Goto (Suc 0)])) na", simp)
        done
    qed
    then obtain stpa where "abc_steps_l (0, xs @ (x - Suc y) # rec_exec (Pr n f g) (xs @ [x - Suc y]) # 0  (ft - Suc (Suc n)) @ Suc y # anything)
            ((?A [+] (?B [+] ?C))) stpa = (length (?A [+] (?B [+] ?C)), 
          xs @ (x - y) # 0 # rec_exec g (xs @ [x - Suc y, rec_exec (Pr n f g) (xs @ [x - Suc y])])
                  # 0  (ft - Suc (Suc (Suc n))) @ y # anything)" ..
    thus "?thesis"
      by(erule_tac abc_append_frist_steps_halt_eq)
  qed
  moreover have 
    " stp. abc_steps_l (length (?A [+] (?B [+] ?C)),
    xs @ (x - y) # 0 # rec_exec g (xs @ [x - Suc y, rec_exec (Pr n f g) (xs @ [x - Suc y])]) # 0  (ft - Suc (Suc (Suc n))) @ y # anything)
    ((?A [+] (?B [+] ?C)) @ ?D) stp  = (0, xs @ (x - y) # rec_exec g (xs @ [x - Suc y, rec_exec (Pr n f g) (xs @ [x - Suc y])]) # 
    0 # 0  (ft - Suc (Suc (Suc n))) @ y # anything)"
    using len
    by(rule_tac loop_back, simp_all)
  moreover have "rec_exec g (xs @ [x - Suc y, rec_exec (Pr n f g) (xs @ [x - Suc y])]) = rec_exec (Pr n f g) (xs @ [x - y])"
    using less
    apply(cases "x - y", simp_all add: rec_exec_pr_Suc_simps)
    apply(rename_tac nat)
    by(subgoal_tac "nat = x - Suc y", simp, arith)    
  ultimately show "?thesis"
    using code ft 
    apply (auto simp add: abc_steps_add replicate_Suc_iff_anywhere)
    apply(rename_tac stp stpa)
    apply(rule_tac x = "stp + stpa" in exI)
    by (simp add: abc_steps_add replicate_Suc_iff_anywhere del: replicate_Suc)
qed

lemma abc_lm_s_simp0[simp]: 
  "length xs = n  abc_lm_s (xs @ x # rec_exec (Pr n f g) (xs @ [x]) # 0  (max (n + 3) 
  (max fft gft) - Suc (Suc n)) @ 0 # anything) (max (n + 3) (max fft gft)) 0 =
    xs @ x # rec_exec (Pr n f g) (xs @ [x]) # 0  (max (n + 3) (max fft gft) - Suc n) @ anything"
  apply(simp add: abc_lm_s.simps)
  using list_update_length[of "xs @ x # rec_exec (Pr n f g) (xs @ [x]) # 0  (max (n + 3) (max fft gft) - Suc (Suc n))"
      0 anything 0]
  apply(auto simp: Suc_diff_Suc)
  apply(simp add: exp_suc[THEN sym] Suc_diff_Suc  del: replicate_Suc)
  done

lemma index_at_zero_elem[simp]:
  "(xs @ x # re # 0  (max (length xs + 3)
  (max fft gft) - Suc (Suc (length xs))) @ 0 # anything) !
    max (length xs + 3) (max fft gft) = 0"
  using nth_append_length[of "xs @ x # re #
  0  (max (length xs + 3) (max fft gft) - Suc (Suc (length xs)))" 0  anything]
  by(simp)

lemma pr_loop_correct:
  assumes less: "y  x" 
    and len: "length xs = n"
    and compile_g: "rec_ci g = (gap, gar, gft)"
    and termi_g: " y<x. terminate g (xs @ [y, rec_exec (Pr n f g) (xs @ [y])])"
    and g_ind: " y<x. (anything. {λnl. nl = xs @ y # rec_exec (Pr n f g) (xs @ [y]) # 0  (gft - gar) @ anything} gap
  {λnl. nl = xs @ y # rec_exec (Pr n f g) (xs @ [y]) # rec_exec g (xs @ [y, rec_exec (Pr n f g) (xs @ [y])]) # 0  (gft - Suc gar) @ anything})"
  shows "{λnl. nl = xs @ (x - y) # rec_exec (Pr n f g) (xs @ [x - y]) # 0  (max (n + 3) (max fft gft) - Suc (Suc n)) @ y # anything}
   ([Dec (max (n + 3) (max fft gft)) (length gap + 7)] [+] (gap [+] [Inc n, Dec (Suc n) 3, Goto (Suc 0)])) @ [Dec (Suc (Suc n)) 0, Inc (Suc n), Goto (length gap + 4)]
   {λnl. nl = xs @ x # rec_exec (Pr n f g) (xs @ [x]) # 0  (max (n + 3) (max fft gft) - Suc n) @ anything}" 
  using less
proof(induct y)
  case 0
  thus "?case"
    using len
    apply(simp add: abc_Hoare_halt_def)
    apply(rule_tac x = 1 in exI)
    by(auto simp: abc_steps_l.simps abc_step_l.simps abc_fetch.simps 
        nth_append abc_comp.simps abc_shift.simps, simp add: abc_lm_v.simps)
next
  case (Suc y)
  let ?ft = "max (n + 3) (max fft gft)"
  let ?C = "[Dec (max (n + 3) (max fft gft)) (length gap + 7)] [+] (gap [+] 
    [Inc n, Dec (Suc n) 3, Goto (Suc 0)]) @ [Dec (Suc (Suc n)) 0, Inc (Suc n), Goto (length gap + 4)]"
  have ind: "y  x 
         {λnl. nl = xs @ (x - y) # rec_exec (Pr n f g) (xs @ [x - y]) # 0  (?ft - Suc (Suc n)) @ y # anything}
         ?C {λnl. nl = xs @ x # rec_exec (Pr n f g) (xs @ [x]) # 0  (?ft - Suc n) @ anything}" by fact 
  have less: "Suc y  x" by fact
  have stp1: 
    " stp. abc_steps_l (0, xs @ (x - Suc y) # rec_exec (Pr n f g) (xs @ [x - Suc y]) # 0  (?ft - Suc (Suc n)) @ Suc y # anything)
    ?C stp  = (0, xs @ (x - y) # rec_exec (Pr n f g) (xs @ [x - y]) # 0  (?ft - Suc (Suc n)) @ y # anything)"
    using assms less
    by(rule_tac  pr_loop, auto)
  then obtain stp1 where a:
    "abc_steps_l (0, xs @ (x - Suc y) # rec_exec (Pr n f g) (xs @ [x - Suc y]) # 0  (?ft - Suc (Suc n)) @ Suc y # anything)
   ?C stp1 = (0, xs @ (x - y) # rec_exec (Pr n f g) (xs @ [x - y]) # 0  (?ft - Suc (Suc n)) @ y # anything)" ..
  moreover have 
    " stp. abc_steps_l (0, xs @ (x - y) # rec_exec (Pr n f g) (xs @ [x - y]) # 0  (?ft - Suc (Suc n)) @ y # anything)
    ?C stp = (length ?C, xs @ x # rec_exec (Pr n f g) (xs @ [x]) # 0  (?ft - Suc n) @ anything)"
    using ind less
    apply(auto simp: abc_Hoare_halt_def)
    apply(rename_tac na,case_tac "abc_steps_l (0, xs @ (x - y) # rec_exec (Pr n f g) 
      (xs @ [x - y]) # 0  (?ft - Suc (Suc n)) @ y # anything) ?C na", rule_tac x = na in exI)
    by simp
  then obtain stp2 where b:
    "abc_steps_l (0, xs @ (x - y) # rec_exec (Pr n f g) (xs @ [x - y]) # 0  (?ft - Suc (Suc n)) @ y # anything)
    ?C stp2 = (length ?C, xs @ x # rec_exec (Pr n f g) (xs @ [x]) # 0  (?ft - Suc n) @ anything)" ..
  from a b show "?case"
    apply(simp add: abc_Hoare_halt_def)
    apply(rule_tac x = "stp1 + stp2" in exI, simp add: abc_steps_add).
qed

lemma compile_pr_correct':
  assumes termi_g: " y<x. terminate g (xs @ [y, rec_exec (Pr n f g) (xs @ [y])])"
    and g_ind: 
    " y<x. (anything. {λnl. nl = xs @ y # rec_exec (Pr n f g) (xs @ [y]) # 0  (gft - gar) @ anything} gap
  {λnl. nl = xs @ y # rec_exec (Pr n f g) (xs @ [y]) # rec_exec g (xs @ [y, rec_exec (Pr n f g) (xs @ [y])]) # 0  (gft - Suc gar) @ anything})"
    and termi_f: "terminate f xs"
    and f_ind: " anything. {λnl. nl = xs @ 0  (fft - far) @ anything} fap {λnl. nl = xs @ rec_exec f xs # 0  (fft - Suc far) @ anything}"
    and len: "length xs = n"
    and compile1: "rec_ci f = (fap, far, fft)"
    and compile2: "rec_ci g = (gap, gar, gft)"
  shows 
    "{λnl. nl = xs @ x # 0  (max (n + 3) (max fft gft) - n) @ anything}
  mv_box n (max (n + 3) (max fft gft)) [+]
  (fap [+] (mv_box n (Suc n) [+]
  ([Dec (max (n + 3) (max fft gft)) (length gap + 7)] [+] (gap [+] [Inc n, Dec (Suc n) 3, Goto (Suc 0)]) @
  [Dec (Suc (Suc n)) 0, Inc (Suc n), Goto (length gap + 4)])))
  {λnl. nl = xs @ x # rec_exec (Pr n f g) (xs @ [x]) # 0  (max (n + 3) (max fft gft) - Suc n) @ anything}"
proof -
  let ?ft = "max (n+3) (max fft gft)"
  let ?A = "mv_box n ?ft"
  let ?B = "fap"
  let ?C = "mv_box n (Suc n)"
  let ?D = "[Dec ?ft (length gap + 7)]"
  let ?E = "gap [+] [Inc n, Dec (Suc n) 3, Goto (Suc 0)]"
  let ?F = "[Dec (Suc (Suc n)) 0, Inc (Suc n), Goto (length gap + 4)]"
  let ?P = "λnl. nl = xs @ x # 0  (?ft - n) @ anything"
  let ?S = "λnl. nl = xs @ x # rec_exec (Pr n f g) (xs @ [x]) # 0  (?ft - Suc n) @ anything"
  let ?Q1 = "λnl. nl = xs @ 0  (?ft - n) @  x # anything"
  show "{?P} (?A [+] (?B [+] (?C [+] (?D [+] ?E @ ?F)))) {?S}"
  proof(rule_tac abc_Hoare_plus_halt)
    show "{?P} ?A {?Q1}"
      using len by simp
  next
    let ?Q2 = "λnl. nl = xs @ rec_exec f xs # 0  (?ft - Suc n) @  x # anything"
    have a: "?ft  fft"
      by arith
    have b: "far = n"
      using compile1 termi_f len
      by(drule_tac param_pattern, auto)
    have c: "fft > far"
      using compile1
      by(simp add: footprint_ge)
    show "{?Q1} (?B [+] (?C [+] (?D [+] ?E @ ?F))) {?S}"
    proof(rule_tac abc_Hoare_plus_halt)
      have "{λnl. nl = xs @ 0  (fft - far) @ 0(?ft - fft) @ x # anything} fap 
            {λnl. nl = xs @ rec_exec f xs # 0  (fft - Suc far) @ 0(?ft - fft) @ x # anything}"
        by(rule_tac f_ind)
      moreover have "fft - far + ?ft - fft = ?ft - far"
        using a b c by arith
      moreover have "fft - Suc n + ?ft - fft = ?ft - Suc n"
        using a b c by arith
      ultimately show "{?Q1} ?B {?Q2}"
        using b
        by(simp add: replicate_merge_anywhere)
    next
      let ?Q3 = "λ nl. nl = xs @ 0 # rec_exec f xs # 0(?ft - Suc (Suc n)) @ x # anything"
      show "{?Q2} (?C [+] (?D [+] ?E @ ?F)) {?S}"
      proof(rule_tac abc_Hoare_plus_halt)
        show "{?Q2} (?C) {?Q3}"
          using mv_box_correct[of n "Suc n" "xs @ rec_exec f xs # 0  (max (n + 3) (max fft gft) - Suc n) @ x # anything"]
          using len
          by(auto)
      next
        show "{?Q3} (?D [+] ?E @ ?F) {?S}"
          using pr_loop_correct[of x x xs n g  gap gar gft f fft anything] assms
          by(simp add: rec_exec_pr_0_simps)
      qed
    qed
  qed
qed 

lemma compile_pr_correct:
  assumes g_ind: "y<x. terminate g (xs @ [y, rec_exec (Pr n f g) (xs @ [y])]) 
  (x xa xb. rec_ci g = (x, xa, xb) 
  (xc. {λnl. nl = xs @ y # rec_exec (Pr n f g) (xs @ [y]) # 0  (xb - xa) @ xc} x
  {λnl. nl = xs @ y # rec_exec (Pr n f g) (xs @ [y]) # rec_exec g (xs @ [y, rec_exec (Pr n f g) (xs @ [y])]) # 0  (xb - Suc xa) @ xc}))"
    and termi_f: "terminate f xs"
    and f_ind:
    "ap arity fp anything.
  rec_ci f = (ap, arity, fp)  {λnl. nl = xs @ 0  (fp - arity) @ anything} ap {λnl. nl = xs @ rec_exec f xs # 0  (fp - Suc arity) @ anything}"
    and len: "length xs = n"
    and compile: "rec_ci (Pr n f g) = (ap, arity, fp)"
  shows "{λnl. nl = xs @ x # 0  (fp - arity) @ anything} ap {λnl. nl = xs @ x # rec_exec (Pr n f g) (xs @ [x]) # 0  (fp - Suc arity) @ anything}"
proof(cases "rec_ci f", cases "rec_ci g")
  fix fap far fft gap gar gft
  assume h: "rec_ci f = (fap, far, fft)" "rec_ci g = (gap, gar, gft)"
  have g: 
    "y<x. (terminate g (xs @ [y, rec_exec (Pr n f g) (xs @ [y])]) 
     (anything. {λnl. nl = xs @ y # rec_exec (Pr n f g) (xs @ [y]) # 0  (gft - gar) @ anything} gap
    {λnl. nl = xs @ y # rec_exec (Pr n f g) (xs @ [y]) # rec_exec g (xs @ [y, rec_exec (Pr n f g) (xs @ [y])]) # 0  (gft - Suc gar) @ anything}))"
    using g_ind h
    by(auto)
  hence termi_g: " y<x. terminate g (xs @ [y, rec_exec (Pr n f g) (xs @ [y])])"
    by simp
  from g have g_newind: 
    " y<x. (anything. {λnl. nl = xs @ y # rec_exec (Pr n f g) (xs @ [y]) # 0  (gft - gar) @ anything} gap
    {λnl. nl = xs @ y # rec_exec (Pr n f g) (xs @ [y]) # rec_exec g (xs @ [y, rec_exec (Pr n f g) (xs @ [y])]) # 0  (gft - Suc gar) @ anything})"
    by auto
  have f_newind: " anything. {λnl. nl = xs @ 0  (fft - far) @ anything} fap {λnl. nl = xs @ rec_exec f xs # 0  (fft - Suc far) @ anything}"
    using h
    by(rule_tac f_ind, simp)
  show "?thesis"
    using termi_f termi_g h compile
    apply(simp add: rec_ci.simps abc_comp_commute, auto)
    using g_newind f_newind len
    by(rule_tac compile_pr_correct', simp_all)
qed

fun mn_ind_inv ::
  "nat × nat list  nat  nat  nat  nat list  nat list  bool"
  where
    "mn_ind_inv (as, lm') ss x rsx suf_lm lm = 
           (if as = ss then lm' = lm @ x # rsx # suf_lm
            else if as = ss + 1 then 
                 y. (lm' = lm @ x # y # suf_lm)  y  rsx
            else if as = ss + 2 then 
                 y. (lm' = lm @ x # y # suf_lm)  y  rsx
            else if as = ss + 3 then lm' = lm @ x # 0 # suf_lm
            else if as = ss + 4 then lm' = lm @ Suc x # 0 # suf_lm
            else if as = 0 then lm' = lm @ Suc x # 0 # suf_lm
            else False
)"

fun mn_stage1 :: "nat × nat list  nat  nat  nat"
  where
    "mn_stage1 (as, lm) ss n = 
            (if as = 0 then 0 
             else if as = ss + 4 then 1
             else if as = ss + 3 then 2
             else if as = ss + 2  as = ss + 1 then 3
             else if as = ss then 4
             else 0
)"

fun mn_stage2 :: "nat × nat list  nat  nat  nat"
  where
    "mn_stage2 (as, lm) ss n = 
            (if as = ss + 1  as = ss + 2 then (lm ! (Suc n))
             else 0)"

fun mn_stage3 :: "nat × nat list  nat  nat  nat"
  where
    "mn_stage3 (as, lm) ss n = (if as = ss + 2 then 1 else 0)"


fun mn_measure :: "((nat × nat list) × nat × nat) 
                                                (nat × nat × nat)"
  where
    "mn_measure ((as, lm), ss, n) = 
     (mn_stage1 (as, lm) ss n, mn_stage2 (as, lm) ss n,
                                       mn_stage3 (as, lm) ss n)"

definition mn_LE :: "(((nat × nat list) × nat × nat) ×
                     ((nat × nat list) × nat × nat)) set"
  where "mn_LE  (inv_image lex_triple mn_measure)"

lemma wf_mn_le[intro]: "wf mn_LE"
  by(auto intro:wf_inv_image wf_lex_triple simp: mn_LE_def)

declare mn_ind_inv.simps[simp del]

lemma put_in_tape_small_enough0[simp]: 
  "0 < rsx  
 y. (xs @ x # rsx # anything)[Suc (length xs) := rsx - Suc 0] = xs @ x # y # anything  y  rsx"
  apply(rule_tac x = "rsx - 1" in exI)
  apply(simp add: list_update_append list_update.simps)
  done

lemma put_in_tape_small_enough1[simp]: 
  "y  rsx; 0 < y
             ya. (xs @ x # y # anything)[Suc (length xs) := y - Suc 0] = xs @ x # ya # anything  ya  rsx"
  apply(rule_tac x = "y - 1" in exI)
  apply(simp add: list_update_append list_update.simps)
  done

lemma abc_comp_null[simp]: "(A [+] B = []) = (A = []  B = [])"
  by(auto simp: abc_comp.simps abc_shift.simps)

lemma rec_ci_not_null[simp]: "(rec_ci f  ([], a, b))"
proof(cases f)
  case (Cn x41 x42 x43)
  then show ?thesis
    by(cases "rec_ci x42", auto simp: mv_box.simps rec_ci.simps rec_ci_id.simps)
next
  case (Pr x51 x52 x53)
  then show ?thesis 
    apply(cases "rec_ci x52", cases "rec_ci x53")
    by (auto simp: mv_box.simps rec_ci.simps rec_ci_id.simps)
next
  case (Mn x61 x62)
  then show ?thesis 
    by(cases "rec_ci x62") (auto simp: rec_ci.simps rec_ci_id.simps)
qed (auto simp: rec_ci_z_def rec_ci_s_def rec_ci.simps addition.simps rec_ci_id.simps)


lemma mn_correct:
  assumes compile: "rec_ci rf = (fap, far, fft)"
    and ge: "0 < rsx"
    and len: "length xs = arity"
    and B: "B = [Dec (Suc arity) (length fap + 5), Dec (Suc arity) (length fap + 3), Goto (Suc (length fap)), Inc arity, Goto 0]"
    and f: "f = (λ stp. (abc_steps_l (length fap, xs @ x # rsx # anything) (fap @ B) stp, (length fap), arity)) "
    and P: "P =(λ ((as, lm), ss, arity). as = 0)"
    and Q: "Q = (λ ((as, lm), ss, arity). mn_ind_inv (as, lm) (length fap) x rsx anything xs)"
  shows " stp. P (f stp)  Q (f stp)"
proof(rule_tac halt_lemma2)
  show "wf mn_LE"
    using wf_mn_le by simp
next
  show "Q (f 0)"
    by(auto simp: Q f abc_steps_l.simps mn_ind_inv.simps)
next
  have "fap  []"
    using compile by auto
  thus "¬ P (f 0)"
    by(auto simp: f P abc_steps_l.simps)
next
  have "fap  []"
    using compile by auto
  then have "¬ P (f stp); Q (f stp)  Q (f (Suc stp))  (f (Suc stp), f stp)  mn_LE" for stp
    using ge len
    apply(cases "(abc_steps_l (length fap, xs @ x # rsx # anything) (fap @ B) stp)")
    apply(simp add: abc_step_red2  B f P Q)
    apply(auto split:if_splits simp add:abc_steps_l.simps  mn_ind_inv.simps abc_steps_zero B abc_fetch.simps nth_append)
    by(auto simp: mn_LE_def lex_triple_def lex_pair_def 
        abc_step_l.simps abc_steps_l.simps mn_ind_inv.simps
        abc_lm_v.simps abc_lm_s.simps nth_append abc_fetch.simps
        split: if_splits)    
  thus "stp. ¬ P (f stp)  Q (f stp)  Q (f (Suc stp))  (f (Suc stp), f stp)  mn_LE"
    by(auto)
qed

lemma abc_Hoare_haltE:
  "{λ nl. nl = lm1} p {λ nl. nl = lm2}
      stp. abc_steps_l (0, lm1) p stp = (length p, lm2)"
  by(auto simp:abc_Hoare_halt_def elim!: abc_holds_for.elims)

lemma mn_loop:
  assumes B:  "B = [Dec (Suc arity) (length fap + 5), Dec (Suc arity) (length fap + 3), Goto (Suc (length fap)), Inc arity, Goto 0]"
    and ft: "ft = max (Suc arity) fft"
    and len: "length xs = arity"
    and far: "far = Suc arity"
    and ind: " (xc. ({λnl. nl = xs @ x # 0  (fft - far) @ xc} fap
    {λnl. nl = xs @ x # rec_exec f (xs @ [x]) # 0  (fft - Suc far) @ xc}))"
    and exec_less: "rec_exec f (xs @ [x]) > 0"
    and compile: "rec_ci f = (fap, far, fft)"
  shows " stp > 0. abc_steps_l (0, xs @ x # 0  (ft - Suc arity) @ anything) (fap @ B) stp =
    (0, xs @ Suc x # 0  (ft - Suc arity) @ anything)"
proof -
  have " stp. abc_steps_l (0, xs @ x # 0  (ft - Suc arity) @ anything) (fap @ B) stp =
    (length fap, xs @ x # rec_exec f (xs @ [x]) # 0  (ft - Suc (Suc arity)) @ anything)"
  proof -
    have " stp. abc_steps_l (0, xs @ x # 0  (ft - Suc arity) @ anything) fap stp =
      (length fap, xs @ x # rec_exec f (xs @ [x]) # 0  (ft - Suc (Suc arity)) @ anything)"
    proof -
      have "{λnl. nl = xs @ x # 0  (fft - far) @ 0(ft - fft) @ anything} fap 
            {λnl. nl = xs @ x # rec_exec f (xs @ [x]) # 0  (fft - Suc far) @ 0(ft - fft) @ anything}"
        using ind by simp
      moreover have "fft > far"
        using compile
        by(erule_tac footprint_ge)
      ultimately show "?thesis"
        using ft far
        apply(drule_tac abc_Hoare_haltE)
        by(simp add: replicate_merge_anywhere max_absorb2)
    qed
    then obtain stp where "abc_steps_l (0, xs @ x # 0  (ft - Suc arity) @ anything) fap stp =
      (length fap, xs @ x # rec_exec f (xs @ [x]) # 0  (ft - Suc (Suc arity)) @ anything)" ..
    thus "?thesis"
      by(erule_tac abc_append_frist_steps_halt_eq)
  qed
  moreover have 
    " stp > 0. abc_steps_l (length fap, xs @ x # rec_exec f (xs @ [x]) # 0  (ft - Suc (Suc arity)) @ anything) (fap @ B) stp =
    (0, xs @ Suc x # 0 # 0  (ft - Suc (Suc arity)) @ anything)"
    using mn_correct[of f fap far fft "rec_exec f (xs @ [x])" xs arity B
        "(λstp. (abc_steps_l (length fap, xs @ x # rec_exec f (xs @ [x]) # 0  (ft - Suc (Suc arity)) @ anything) (fap @ B) stp, length fap, arity))"     
        x "0  (ft - Suc (Suc arity)) @ anything" "(λ((as, lm), ss, arity). as = 0)" 
        "(λ((as, lm), ss, aritya). mn_ind_inv (as, lm) (length fap) x (rec_exec f (xs @ [x])) (0  (ft - Suc (Suc arity)) @ anything) xs) "]  
      B compile  exec_less len
    apply(subgoal_tac "fap  []", auto)
    apply(rename_tac stp y)
    apply(rule_tac x = stp in exI, auto simp: mn_ind_inv.simps)
    by(case_tac "stp", simp_all add: abc_steps_l.simps)
  moreover have "fft > far"
    using compile
    by(erule_tac footprint_ge)
  ultimately show "?thesis"
    using ft far
    apply(auto) apply(rename_tac stp1 stp2)
    by(rule_tac x = "stp1 + stp2" in exI, 
        simp add: abc_steps_add replicate_Suc[THEN sym] diff_Suc_Suc del: replicate_Suc)
qed

lemma mn_loop_correct': 
  assumes B:  "B = [Dec (Suc arity) (length fap + 5), Dec (Suc arity) (length fap + 3), Goto (Suc (length fap)), Inc arity, Goto 0]"
    and ft: "ft = max (Suc arity) fft"
    and len: "length xs = arity"
    and ind_all: "ix. (xc. ({λnl. nl = xs @ i # 0  (fft - far) @ xc} fap
    {λnl. nl = xs @ i # rec_exec f (xs @ [i]) # 0  (fft - Suc far) @ xc}))"
    and exec_ge: " ix. rec_exec f (xs @ [i]) > 0"
    and compile: "rec_ci f = (fap, far, fft)"
    and far: "far = Suc arity"
  shows " stp > x. abc_steps_l (0, xs @ 0 # 0  (ft - Suc arity) @ anything) (fap @ B) stp = 
               (0, xs @ Suc x # 0  (ft - Suc arity) @ anything)"
  using ind_all exec_ge
proof(induct x)
  case 0
  thus "?case"
    using assms
    by(rule_tac mn_loop, simp_all)
next
  case (Suc x)
  have ind': "ix. xc. {λnl. nl = xs @ i # 0  (fft - far) @ xc} fap {λnl. nl = xs @ i # rec_exec f (xs @ [i]) # 0  (fft - Suc far) @ xc};
               ix. 0 < rec_exec f (xs @ [i])  
            stp > x. abc_steps_l (0, xs @ 0 # 0  (ft - Suc arity) @ anything) (fap @ B) stp = (0, xs @ Suc x # 0  (ft - Suc arity) @ anything)" by fact
  have exec_ge: "iSuc x. 0 < rec_exec f (xs @ [i])" by fact
  have ind_all: "iSuc x. xc. {λnl. nl = xs @ i # 0  (fft - far) @ xc} fap 
    {λnl. nl = xs @ i # rec_exec f (xs @ [i]) # 0  (fft - Suc far) @ xc}" by fact
  have ind: "stp > x. abc_steps_l (0, xs @ 0 # 0  (ft - Suc arity) @ anything) (fap @ B) stp =
    (0, xs @ Suc x # 0  (ft - Suc arity) @ anything)" using ind' exec_ge ind_all by simp
  have stp: " stp > 0. abc_steps_l (0, xs @ Suc x # 0  (ft - Suc arity) @ anything) (fap @ B) stp =
    (0, xs @ Suc (Suc x) # 0  (ft - Suc arity) @ anything)"
    using ind_all exec_ge B ft len far compile
    by(rule_tac mn_loop, simp_all)
  from ind stp show "?case"
    apply(auto simp add: abc_steps_add)
    apply(rename_tac stp1 stp2)
    by(rule_tac x = "stp1 + stp2" in exI, simp add: abc_steps_add)
qed

lemma mn_loop_correct: 
  assumes B:  "B = [Dec (Suc arity) (length fap + 5), Dec (Suc arity) (length fap + 3), Goto (Suc (length fap)), Inc arity, Goto 0]"
    and ft: "ft = max (Suc arity) fft"
    and len: "length xs = arity"
    and ind_all: "ix. (xc. ({λnl. nl = xs @ i # 0  (fft - far) @ xc} fap
    {λnl. nl = xs @ i # rec_exec f (xs @ [i]) # 0  (fft - Suc far) @ xc}))"
    and exec_ge: " ix. rec_exec f (xs @ [i]) > 0"
    and compile: "rec_ci f = (fap, far, fft)"
    and far: "far = Suc arity"
  shows " stp. abc_steps_l (0, xs @ 0 # 0  (ft - Suc arity) @ anything) (fap @ B) stp = 
               (0, xs @ Suc x # 0  (ft - Suc arity) @ anything)"
proof -
  have "stp>x. abc_steps_l (0, xs @ 0 # 0  (ft - Suc arity) @ anything) (fap @ B) stp = (0, xs @ Suc x # 0  (ft - Suc arity) @ anything)"
    using assms
    by(rule_tac mn_loop_correct', simp_all)
  thus "?thesis"
    by(auto)
qed

lemma compile_mn_correct': 
  assumes B:  "B = [Dec (Suc arity) (length fap + 5), Dec (Suc arity) (length fap + 3), Goto (Suc (length fap)), Inc arity, Goto 0]"
    and ft: "ft = max (Suc arity) fft"
    and len: "length xs = arity"
    and termi_f: "terminate f (xs @ [r])"
    and f_ind: "anything. {λnl. nl = xs @ r # 0  (fft - far) @ anything} fap 
        {λnl. nl = xs @ r # 0 # 0  (fft - Suc far) @ anything}"
    and ind_all: "i < r. (xc. ({λnl. nl = xs @ i # 0  (fft - far) @ xc} fap
    {λnl. nl = xs @ i # rec_exec f (xs @ [i]) # 0  (fft - Suc far) @ xc}))"
    and exec_less: " i<r. rec_exec f (xs @ [i]) > 0"
    and exec: "rec_exec f (xs @ [r]) = 0"
    and compile: "rec_ci f = (fap, far, fft)"
  shows "{λnl. nl = xs @ 0  (max (Suc arity) fft - arity) @ anything}
    fap @ B
    {λnl. nl = xs @ rec_exec (Mn arity f) xs # 0  (max (Suc arity) fft - Suc arity) @ anything}"
proof -
  have a: "far = Suc arity"
    using len compile termi_f
    by(drule_tac param_pattern, auto)
  have b: "fft > far"
    using compile
    by(erule_tac footprint_ge)
  have " stp. abc_steps_l (0, xs @ 0 # 0  (ft - Suc arity) @ anything) (fap @ B) stp = 
    (0, xs @ r # 0  (ft - Suc arity) @ anything)"
    using assms a
    apply(cases r, rule_tac x = 0 in exI, simp add: abc_steps_l.simps, simp)
    by(rule_tac mn_loop_correct, auto)  
  moreover have 
    " stp. abc_steps_l (0, xs @ r # 0  (ft - Suc arity) @ anything) (fap @ B) stp = 
    (length fap, xs @ r # rec_exec f (xs @ [r]) # 0  (ft - Suc (Suc arity)) @ anything)"
  proof -
    have " stp. abc_steps_l (0, xs @ r # 0  (ft - Suc arity) @ anything) fap stp =
      (length fap, xs @ r # rec_exec f (xs @ [r]) # 0  (ft - Suc (Suc arity)) @ anything)"
    proof -
      have "{λnl. nl = xs @ r # 0  (fft - far) @ 0(ft - fft) @ anything} fap 
            {λnl. nl = xs @ r # rec_exec f (xs @ [r]) # 0  (fft - Suc far) @ 0(ft - fft) @ anything}"
        using f_ind exec by simp
      thus "?thesis"
        using ft a b
        apply(drule_tac abc_Hoare_haltE)
        by(simp add: replicate_merge_anywhere max_absorb2)
    qed
    then obtain stp where "abc_steps_l (0, xs @ r # 0  (ft - Suc arity) @ anything) fap stp =
      (length fap, xs @ r # rec_exec f (xs @ [r]) # 0  (ft - Suc (Suc arity)) @ anything)" ..
    thus "?thesis"
      by(erule_tac abc_append_frist_steps_halt_eq)
  qed
  moreover have 
    " stp. abc_steps_l (length fap, xs @ r # rec_exec f (xs @ [r]) # 0  (ft - Suc (Suc arity)) @ anything) (fap @ B) stp = 
             (length fap + 5, xs @ r # rec_exec f (xs @ [r]) # 0  (ft - Suc (Suc arity)) @ anything)"
    using ft a b len B exec
    apply(rule_tac x = 1 in exI, auto)
    by(auto simp: abc_steps_l.simps B abc_step_l.simps 
        abc_fetch.simps nth_append max_absorb2 abc_lm_v.simps abc_lm_s.simps)
  moreover have "rec_exec (Mn (length xs) f) xs = r"
    using exec exec_less
    apply(auto simp: rec_exec.simps Least_def)
    thm the_equality
    apply(rule_tac the_equality, auto)
     apply(metis exec_less less_not_refl3 linorder_not_less)
    by (metis le_neq_implies_less less_not_refl3)
  ultimately show "?thesis"
    using ft a b len B exec
    apply(auto simp: abc_Hoare_halt_def)
    apply(rename_tac stp1 stp2 stp3)
    apply(rule_tac x = "stp1 + stp2 + stp3"  in exI)
    by(simp add: abc_steps_add replicate_Suc_iff_anywhere max_absorb2 Suc_diff_Suc del: replicate_Suc)
qed

lemma compile_mn_correct:
  assumes len: "length xs = n"
    and termi_f: "terminate f (xs @ [r])"
    and f_ind: "ap arity fp anything. rec_ci f = (ap, arity, fp)  
  {λnl. nl = xs @ r # 0  (fp - arity) @ anything} ap {λnl. nl = xs @ r # 0 # 0  (fp - Suc arity) @ anything}"
    and exec: "rec_exec f (xs @ [r]) = 0"
    and ind_all: 
    "i<r. terminate f (xs @ [i]) 
  (x xa xb. rec_ci f = (x, xa, xb)  
  (xc. {λnl. nl = xs @ i # 0  (xb - xa) @ xc} x {λnl. nl = xs @ i # rec_exec f (xs @ [i]) # 0  (xb - Suc xa) @ xc})) 
  0 < rec_exec f (xs @ [i])"
    and compile: "rec_ci (Mn n f) = (ap, arity, fp)"
  shows "{λnl. nl = xs @ 0  (fp - arity) @ anything} ap 
  {λnl. nl = xs @ rec_exec (Mn n f) xs # 0  (fp - Suc arity) @ anything}"
proof(cases "rec_ci f")
  fix fap far fft
  assume h: "rec_ci f = (fap, far, fft)"
  hence f_newind: 
    "anything. {λnl. nl = xs @ r # 0  (fft - far) @ anything} fap 
        {λnl. nl = xs @ r # 0 # 0  (fft - Suc far) @ anything}"
    by(rule_tac f_ind, simp)
  have newind_all: 
    "i < r. (xc. ({λnl. nl = xs @ i # 0  (fft - far) @ xc} fap
    {λnl. nl = xs @ i # rec_exec f (xs @ [i]) # 0  (fft - Suc far) @ xc}))"
    using ind_all h
    by(auto)
  have all_less: " i<r. rec_exec f (xs @ [i]) > 0"
    using ind_all by auto
  show "?thesis"
    using h compile f_newind newind_all all_less len termi_f exec
    apply(auto simp: rec_ci.simps)
    by(rule_tac compile_mn_correct', auto)
qed

lemma recursive_compile_correct:
  "terminate recf args; rec_ci recf = (ap, arity, fp)
   {λ nl. nl = args @ 0(fp - arity) @ anything} ap 
         {λ nl. nl = args@ rec_exec recf args # 0(fp - Suc arity) @ anything}"
  apply(induct arbitrary: ap arity fp anything rule: terminate.induct)
       apply(simp_all add: compile_s_correct compile_z_correct compile_id_correct 
      compile_cn_correct compile_pr_correct compile_mn_correct)
  done

definition dummy_abc :: "nat  abc_inst list"
  where
    "dummy_abc k = [Inc k, Dec k 0, Goto 3]"

definition abc_list_crsp:: "nat list  nat list  bool"
  where
    "abc_list_crsp xs ys = ( n. xs = ys @ 0n  ys = xs @ 0n)"

lemma abc_list_crsp_simp1[intro]: "abc_list_crsp (lm @ 0m) lm"
  by(auto simp: abc_list_crsp_def)


lemma abc_list_crsp_lm_v: 
  "abc_list_crsp lma lmb  abc_lm_v lma n = abc_lm_v lmb n"
  by(auto simp: abc_list_crsp_def abc_lm_v.simps 
      nth_append)


lemma abc_list_crsp_elim: 
  "abc_list_crsp lma lmb;  n. lma = lmb @ 0n  lmb = lma @ 0n  P   P"
  by(auto simp: abc_list_crsp_def)

lemma abc_list_crsp_simp[simp]: 
  "abc_list_crsp lma lmb; m < length lma; m < length lmb 
          abc_list_crsp (lma[m := n]) (lmb[m := n])"
  by(auto simp: abc_list_crsp_def list_update_append)

lemma abc_list_crsp_simp2[simp]: 
  "abc_list_crsp lma lmb; m < length lma; ¬ m < length lmb  
  abc_list_crsp (lma[m := n]) (lmb @ 0  (m - length lmb) @ [n])"
  apply(auto simp: abc_list_crsp_def list_update_append)
  apply(rename_tac N)
  apply(rule_tac x = "N + length lmb - Suc m" in exI)
  apply(rule_tac disjI1)
  apply(simp add: upd_conv_take_nth_drop min_absorb1)
  done

lemma abc_list_crsp_simp3[simp]:
  "abc_list_crsp lma lmb; ¬ m < length lma; m < length lmb  
  abc_list_crsp (lma @ 0  (m - length lma) @ [n]) (lmb[m := n])"
  apply(auto simp: abc_list_crsp_def list_update_append)
  apply(rename_tac N)
  apply(rule_tac x = "N + length lma - Suc m" in exI)
  apply(rule_tac disjI2)
  apply(simp add: upd_conv_take_nth_drop min_absorb1)
  done

lemma abc_list_crsp_simp4[simp]: "abc_list_crsp lma lmb; ¬ m < length lma; ¬ m < length lmb  
  abc_list_crsp (lma @ 0  (m - length lma) @ [n]) (lmb @ 0  (m - length lmb) @ [n])"
  by(auto simp: abc_list_crsp_def list_update_append replicate_merge_anywhere)

lemma abc_list_crsp_lm_s: 
  "abc_list_crsp lma lmb  
      abc_list_crsp (abc_lm_s lma m n) (abc_lm_s lmb m n)"
  by(auto simp: abc_lm_s.simps)

lemma abc_list_crsp_step: 
  "abc_list_crsp lma lmb; abc_step_l (aa, lma) i = (a, lma'); 
    abc_step_l (aa, lmb) i = (a', lmb')
     a' = a  abc_list_crsp lma' lmb'"
  apply(cases i, auto simp: abc_step_l.simps 
      abc_list_crsp_lm_s abc_list_crsp_lm_v 
      split: abc_inst.splits if_splits)
  done

lemma abc_list_crsp_steps: 
  "abc_steps_l (0, lm @ 0m) aprog stp = (a, lm'); aprog  [] 
        lma. abc_steps_l (0, lm) aprog stp = (a, lma)  
                                          abc_list_crsp lm' lma"
proof(induct stp arbitrary: a lm')
  case (Suc stp)
  then show ?case using [[simproc del: defined_all]] apply(cases "abc_steps_l (0, lm @ 0m) aprog stp", simp add: abc_step_red)
  proof -
    fix stp a lm' aa b
    assume ind:
      "a lm'. aa = a  b = lm'  
     lma. abc_steps_l (0, lm) aprog stp = (a, lma) 
                                          abc_list_crsp lm' lma"
      and h: "abc_step_l (aa, b) (abc_fetch aa aprog) = (a, lm')" 
      "abc_steps_l (0, lm @ 0m) aprog stp = (aa, b)" 
      "aprog  []"
    have "lma. abc_steps_l (0, lm) aprog stp = (aa, lma)  
              abc_list_crsp b lma"
      apply(rule_tac ind, simp)
      done
    from this obtain lma where g2: 
      "abc_steps_l (0, lm) aprog stp = (aa, lma)  
     abc_list_crsp b lma"   ..
    hence g3: "abc_steps_l (0, lm) aprog (Suc stp)
          = abc_step_l (aa, lma) (abc_fetch aa aprog)"
      apply(rule_tac abc_step_red, simp)
      done
    show "lma. abc_steps_l (0, lm) aprog (Suc stp) = (a, lma)  abc_list_crsp lm' lma"
      using g2 g3 h
      apply(auto)
      apply(cases "abc_step_l (aa, b) (abc_fetch aa aprog)",
          cases "abc_step_l (aa, lma) (abc_fetch aa aprog)", simp)
      apply(rule_tac abc_list_crsp_step, auto)
      done
  qed
qed (force simp add: abc_steps_l.simps)

lemma list_crsp_simp2: "abc_list_crsp (lm1 @ 0n) lm2  abc_list_crsp lm1 lm2"
proof(induct n)
  case 0
  thus "?case"
    by(auto simp: abc_list_crsp_def)
next
  case (Suc n)
  have ind: "abc_list_crsp (lm1 @ 0  n) lm2  abc_list_crsp lm1 lm2" by fact
  have h: "abc_list_crsp (lm1 @ 0  Suc n) lm2" by fact
  then have "abc_list_crsp (lm1 @ 0  n) lm2"
    apply(auto simp only: exp_suc abc_list_crsp_def del: replicate_Suc)
     apply (metis Suc_pred append_eq_append_conv
        append_eq_append_conv2 butlast_append butlast_snoc length_replicate list.distinct(1)
        neq0_conv replicate_Suc replicate_Suc_iff_anywhere replicate_app_Cons_same 
        replicate_empty self_append_conv self_append_conv2)
    apply (auto,metis replicate_Suc)
    .
  thus "?case"
    using ind
    by auto
qed

lemma recursive_compile_correct_norm': 
  "rec_ci f = (ap, arity, ft);  
    terminate f args
    stp rl. (abc_steps_l (0, args) ap stp) = (length ap, rl)  abc_list_crsp (args @ [rec_exec f args]) rl"
  using recursive_compile_correct[of f args ap arity ft "[]"]
  apply(auto simp: abc_Hoare_halt_def)
  apply(rename_tac n)
  apply(rule_tac x = n in exI)
  apply(case_tac "abc_steps_l (0, args @ 0  (ft - arity)) ap n", auto)
  apply(drule_tac abc_list_crsp_steps, auto)
  apply(rule_tac list_crsp_simp2, auto)
  done

lemma find_exponent_rec_exec[simp]:
  assumes a: "args @ [rec_exec f args] = lm @ 0  n"
    and b: "length args < length lm"
  shows "m. lm = args @ rec_exec f args # 0  m"
  using assms
  apply(cases n, simp)
   apply(rule_tac x = 0 in exI, simp)
  apply(drule_tac length_equal, simp)
  done

lemma find_exponent_complex[simp]: 
  "args @ [rec_exec f args] = lm @ 0  n; ¬ length args < length lm
   m. (lm @ 0  (length args - length lm) @ [Suc 0])[length args := 0] =
  args @ rec_exec f args # 0  m"
  apply(cases n, simp_all add: exp_suc list_update_append list_update.simps del: replicate_Suc)
   apply(subgoal_tac "length args = Suc (length lm)", simp)
    apply(rule_tac x = "Suc (Suc 0)" in exI, simp)
   apply(drule_tac length_equal, simp, auto)
  done

lemma compile_append_dummy_correct: 
  assumes compile: "rec_ci f = (ap, ary, fp)"
    and termi: "terminate f args"
  shows "{λ nl. nl = args} (ap [+] dummy_abc (length args)) {λ nl. ( m. nl = args @ rec_exec f args # 0m)}"
proof(rule_tac abc_Hoare_plus_halt)
  show "{λnl. nl = args} ap {λ nl. abc_list_crsp (args @ [rec_exec f args]) nl}"
    using compile termi recursive_compile_correct_norm'[of f ap ary fp args]
    apply(auto simp: abc_Hoare_halt_def)
    by (metis abc_final.simps abc_holds_for.simps)
next
  show "{abc_list_crsp (args @ [rec_exec f args])} dummy_abc (length args) 
    {λnl. m. nl = args @ rec_exec f args # 0  m}"
    apply(auto simp: dummy_abc_def abc_Hoare_halt_def)
    apply(rule_tac x = 3 in exI)
    by(force simp: abc_steps_l.simps abc_list_crsp_def abc_step_l.simps numeral_3_eq_3 abc_fetch.simps
        abc_lm_v.simps nth_append abc_lm_s.simps)
qed

lemma cn_merge_gs_split: 
  "i < length gs; rec_ci (gs!i) = (ga, gb, gc)  
  cn_merge_gs (map rec_ci gs) p =  cn_merge_gs (map rec_ci (take i gs)) p [+] (ga [+] 
       mv_box gb (p + i)) [+]  cn_merge_gs (map rec_ci (drop (Suc i) gs)) (p + Suc i)"
proof(induct i arbitrary: gs p)
  case 0
  then show ?case by(cases gs; simp)
next
  case (Suc i)
  then show ?case 
    by(cases gs, simp, cases "rec_ci (hd gs)", 
        simp add: abc_comp_commute[THEN sym])
qed

lemma cn_unhalt_case:
  assumes compile1: "rec_ci (Cn n f gs) = (ap, ar, ft)  length args = ar"
    and g: "i < length gs"
    and compile2: "rec_ci (gs!i) = (gap, gar, gft)  gar = length args"
    and g_unhalt: " anything. {λ nl. nl = args @ 0(gft - gar) @ anything} gap "
    and g_ind: " apj arj ftj j anything. j < i; rec_ci (gs!j) = (apj, arj, ftj) 
   {λ nl. nl = args @ 0(ftj - arj) @ anything} apj {λ nl. nl = args @ rec_exec (gs!j) args # 0(ftj - Suc arj) @ anything}"
    and all_termi: " j<i. terminate (gs!j) args"
  shows "{λ nl. nl = args @ 0(ft - ar) @ anything} ap "
  using compile1
  apply(cases "rec_ci f", auto simp: rec_ci.simps abc_comp_commute)
proof(rule_tac abc_Hoare_plus_unhalt1)
  fix fap far fft
  let ?ft = "max (Suc (length args)) (Max (insert fft ((λ(aprog, p, n). n) ` rec_ci ` set gs)))"
  let ?Q = "λnl. nl = args @ 0 (?ft - length args) @ map (λi. rec_exec i args) (take i gs) @ 
    0(length gs - i) @ 0 Suc (length args) @ anything"
  have "cn_merge_gs (map rec_ci gs) ?ft = 
    cn_merge_gs (map rec_ci (take i gs)) ?ft [+] (gap [+] 
    mv_box gar (?ft + i)) [+]  cn_merge_gs (map rec_ci (drop (Suc i) gs)) (?ft + Suc i)"
    using g compile2 cn_merge_gs_split by simp
  thus "{λnl. nl = args @ 0 # 0  (?ft + length gs) @ anything} (cn_merge_gs (map rec_ci gs) ?ft) "
  proof(simp, rule_tac abc_Hoare_plus_unhalt1, rule_tac abc_Hoare_plus_unhalt2, 
      rule_tac abc_Hoare_plus_unhalt1)
    let ?Q_tmp = "λnl. nl = args @ 0 (gft - gar) @ 0(?ft - (length args) - (gft -gar)) @ map (λi. rec_exec i args) (take i gs) @ 
      0(length gs - i) @ 0 Suc (length args) @ anything"
    have a: "{?Q_tmp} gap "
      using g_unhalt[of "0  (?ft - (length args) - (gft - gar)) @
        map (λi. rec_exec i args) (take i gs) @ 0  (length gs - i) @ 0  Suc (length args) @ anything"]
      by simp
    moreover have "?ft  gft"
      using g compile2
      apply(rule_tac max.coboundedI2, rule_tac Max_ge, simp, rule_tac insertI2)
      apply(rule_tac  x = "rec_ci (gs ! i)" in image_eqI, simp)
      by(rule_tac x = "gs!i"  in image_eqI, simp, simp)
    then have b:"?Q_tmp = ?Q"
      using compile2
      apply(rule_tac arg_cong)
      by(simp add: replicate_merge_anywhere)
    thus "{?Q} gap "
      using a by simp
  next
    show "{λnl. nl = args @ 0 # 0  (?ft + length gs) @ anything} 
      cn_merge_gs (map rec_ci (take i gs)) ?ft
       {λnl. nl = args @ 0  (?ft - length args) @
      map (λi. rec_exec i args) (take i gs) @ 0  (length gs - i) @ 0  Suc (length args) @ anything}"
      using all_termi
      by(rule_tac compile_cn_gs_correct', auto simp: set_conv_nth intro:g_ind)
  qed
qed



lemma mn_unhalt_case':
  assumes compile: "rec_ci f = (a, b, c)"
    and all_termi: "i. terminate f (args @ [i])  0 < rec_exec f (args @ [i])"
    and B: "B = [Dec (Suc (length args)) (length a + 5), Dec (Suc (length args)) (length a + 3), 
  Goto (Suc (length a)), Inc (length args), Goto 0]"
  shows "{λnl. nl = args @ 0  (max (Suc (length args)) c - length args) @ anything}
  a @ B "
proof(rule_tac abc_Hoare_unhaltI, auto)
  fix n
  have a:  "b = Suc (length args)"
    using all_termi compile
    apply(erule_tac x = 0 in allE)
    by(auto, drule_tac param_pattern,auto)
  moreover have b: "c > b"
    using compile by(elim footprint_ge)
  ultimately have c: "max (Suc (length args)) c = c" by arith
  have " stp > n. abc_steps_l (0, args @ 0 # 0(c - Suc (length args)) @ anything) (a @ B) stp
         = (0, args @ Suc n # 0(c - Suc (length args)) @ anything)"
    using assms a b c
  proof(rule_tac mn_loop_correct', auto)
    fix i xc
    show "{λnl. nl = args @ i # 0  (c - Suc (length args)) @ xc} a 
      {λnl. nl = args @ i # rec_exec f (args @ [i]) # 0  (c - Suc (Suc (length args))) @ xc}"
      using all_termi recursive_compile_correct[of f "args @ [i]" a b c xc] compile a
      by(simp)
  qed
  then obtain stp where d: "stp > n  abc_steps_l (0, args @ 0 # 0(c - Suc (length args)) @ anything) (a @ B) stp
         = (0, args @ Suc n # 0(c - Suc (length args)) @ anything)" ..
  then obtain d where e: "stp = n + Suc d"
    by (metis add_Suc_right less_iff_Suc_add)
  obtain s nl where f: "abc_steps_l (0, args @ 0 # 0(c - Suc (length args)) @ anything) (a @ B) n = (s, nl)"
    by (metis prod.exhaust)
  have g: "s < length (a @ B)"
    using d e f
    apply(rule_tac classical, simp only: abc_steps_add)
    by(simp add: halt_steps2 leI)
  from f g show "abc_notfinal (abc_steps_l (0, args @ 0  
    (max (Suc (length args)) c - length args) @ anything) (a @ B) n) (a @ B)"
    using c b a
    by(simp add: replicate_Suc_iff_anywhere Suc_diff_Suc del: replicate_Suc)
qed

lemma mn_unhalt_case: 
  assumes compile: "rec_ci (Mn n f) = (ap, ar, ft)  length args = ar"
    and all_term: " i. terminate f (args @ [i])  rec_exec f (args @ [i]) > 0"
  shows "{λ nl. nl = args @ 0(ft - ar) @ anything} ap  "
  using assms
  apply(cases "rec_ci f", auto simp: rec_ci.simps abc_comp_commute)
  by(rule_tac mn_unhalt_case', simp_all)

fun tm_of_rec :: "recf  instr list"
  where "tm_of_rec recf = (let (ap, k, fp) = rec_ci recf in
                         let tp = tm_of (ap [+] dummy_abc k) in 
                           tp @ (shift (mopup k) (length tp div 2)))"

lemma recursive_compile_to_tm_correct1: 
  assumes  compile: "rec_ci recf = (ap, ary, fp)"
    and termi: " terminate recf args"
    and tp: "tp = tm_of (ap [+] dummy_abc (length args))"
  shows " stp m l. steps0 (Suc 0, Bk # Bk # ires, <args> @ Bkrn)
  (tp @ shift (mopup (length args)) (length tp div 2)) stp = (0, Bkm @ Bk # Bk # ires, OcSuc (rec_exec recf args) @ Bkl)"
proof -
  have "{λnl. nl = args} ap [+] dummy_abc (length args) {λnl. m. nl = args @ rec_exec recf args # 0  m}"
    using compile termi compile
    by(rule_tac compile_append_dummy_correct, auto)
  then obtain stp m where h: "abc_steps_l (0, args) (ap [+] dummy_abc (length args)) stp = 
    (length (ap [+] dummy_abc (length args)), args @ rec_exec recf args # 0m) "
    apply(simp add: abc_Hoare_halt_def, auto)
    apply(rename_tac n)
    by(case_tac "abc_steps_l (0, args) (ap [+] dummy_abc (length args)) n", auto)
  thus "?thesis"
    using assms tp compile_correct_halt[OF refl refl _ h _ _ refl]
    by(auto simp: crsp.simps start_of.simps abc_lm_v.simps)
qed

lemma recursive_compile_to_tm_correct2: 
  assumes termi: " terminate recf args"
  shows " stp m l. steps0 (Suc 0, [Bk, Bk], <args>) (tm_of_rec recf) stp = 
                     (0, BkSuc (Suc m), OcSuc (rec_exec recf args) @ Bkl)"
proof(cases "rec_ci recf", simp add: tm_of_rec.simps)
  fix ap ar fp
  assume "rec_ci recf = (ap, ar, fp)"
  thus "stp m l. steps0 (Suc 0, [Bk, Bk], <args>) 
    (tm_of (ap [+] dummy_abc ar) @ shift (mopup ar) (sum_list (layout_of (ap [+] dummy_abc ar)))) stp =
    (0, Bk # Bk # Bk  m, Oc # Oc  rec_exec recf args @ Bk  l)"
    using recursive_compile_to_tm_correct1[of recf ap ar fp args "tm_of (ap [+] dummy_abc (length args))" "[]" 0]
      assms param_pattern[of recf args ap ar fp]
    by(simp add: replicate_Suc[THEN sym] replicate_Suc_iff_anywhere del: replicate_Suc, 
        simp add: exp_suc del: replicate_Suc)
qed

lemma recursive_compile_to_tm_correct3: 
  assumes termi: "terminate recf args"
  shows "{λ tp. tp =([Bk, Bk], <args>)} (tm_of_rec recf) 
         {λ tp.  k l. tp = (Bk k, <rec_exec recf args> @ Bk  l)}"
  using recursive_compile_to_tm_correct2[OF assms]
  apply(auto simp add: Hoare_halt_def ) apply(rename_tac stp M l)
  apply(rule_tac x = stp in exI)
  apply(auto simp add: tape_of_nat_def)
  apply(rule_tac x = "Suc (Suc M)" in exI)
  apply(simp)
  done 

lemma list_all_suc_many[simp]:
  "list_all (λ(acn, s). s  Suc (Suc (Suc (Suc (Suc (Suc (2 * n))))))) xs 
  list_all (λ(acn, s). s  Suc (Suc (Suc (Suc (Suc (Suc (Suc (Suc (2 * n))))))))) xs"
proof(induct xs)
  case (Cons a xs)
  then show ?case by(cases a, simp)
qed simp


lemma shift_append: "shift (xs @ ys) n = shift xs n @ shift ys n"
  apply(simp add: shift.simps)
  done

lemma length_shift_mopup[simp]: "length (shift (mopup n) ss) = 4 * n + 12"
  apply(auto simp: mopup.simps shift_append mopup_b_def)
  done

lemma length_tm_even[intro]: "length (tm_of ap) mod 2 = 0"
  apply(simp add: tm_of.simps)
  done

lemma tms_of_at_index[simp]: "k < length ap  tms_of ap ! k  = 
 ci (layout_of ap) (start_of (layout_of ap) k) (ap ! k)"
  apply(simp add: tms_of.simps tpairs_of.simps)
  done

lemma start_of_suc_inc:
  "k < length ap; ap ! k = Inc n  start_of (layout_of ap) (Suc k) =
                        start_of (layout_of ap) k + 2 * n + 9"
  apply(rule_tac start_of_Suc1, auto simp: abc_fetch.simps)
  done

lemma start_of_suc_dec:
  "k < length ap; ap ! k = (Dec n e)  start_of (layout_of ap) (Suc k) =
                        start_of (layout_of ap) k + 2 * n + 16"
  apply(rule_tac start_of_Suc2, auto simp: abc_fetch.simps)
  done

lemma inc_state_all_le:
  "k < length ap; ap ! k = Inc n; 
       (a, b)  set (shift (shift tinc_b (2 * n)) 
                            (start_of (layout_of ap) k - Suc 0))
        b  start_of (layout_of ap) (length ap)"
  apply(subgoal_tac "b  start_of (layout_of ap) (Suc k)")
   apply(subgoal_tac "start_of (layout_of ap) (Suc k)  start_of (layout_of ap) (length ap) ")
    apply(arith)
   apply(cases "Suc k = length ap", simp)
   apply(rule_tac start_of_less, simp)
  apply(auto simp: tinc_b_def shift.simps start_of_suc_inc length_of.simps )
  done

lemma findnth_le[elim]: 
  "(a, b)  set (shift (findnth n) (start_of (layout_of ap) k - Suc 0))
   b  Suc (start_of (layout_of ap) k + 2 * n)"
  apply(induct n, force simp add: shift.simps)
  apply(simp add: shift_append, auto)
  apply(auto simp: shift.simps)
  done

lemma findnth_state_all_le1:
  "k < length ap; ap ! k = Inc n;
  (a, b)  
  set (shift (findnth n) (start_of (layout_of ap) k - Suc 0)) 
   b  start_of (layout_of ap) (length ap)"
  apply(subgoal_tac "b  start_of (layout_of ap) (Suc k)")
   apply(subgoal_tac "start_of (layout_of ap) (Suc k)  start_of (layout_of ap) (length ap) ")
    apply(arith)
   apply(cases "Suc k = length ap", simp)
   apply(rule_tac start_of_less, simp)
  apply(subgoal_tac "b  start_of (layout_of ap) k + 2*n + 1  
     start_of (layout_of ap) k + 2*n + 1   start_of (layout_of ap) (Suc k)", auto)
  apply(auto simp: tinc_b_def shift.simps length_of.simps  start_of_suc_inc)
  done

lemma start_of_eq: "length ap < as  start_of (layout_of ap) as = start_of (layout_of ap) (length ap)"
proof(induct as)
  case (Suc as)
  then show ?case 
    apply(cases "length ap < as", simp add: start_of.simps)
    apply(subgoal_tac "as = length ap")
     apply(simp add: start_of.simps)
    apply arith
    done
qed simp

lemma start_of_all_le: "start_of (layout_of ap) as  start_of (layout_of ap) (length ap)"
  apply(subgoal_tac "as > length ap  as = length ap  as < length ap", 
      auto simp: start_of_eq start_of_less)
  done

lemma findnth_state_all_le2: 
  "k < length ap; 
  ap ! k = Dec n e;
  (a, b)  set (shift (findnth n) (start_of (layout_of ap) k - Suc 0))
   b  start_of (layout_of ap) (length ap)"
  apply(subgoal_tac "b  start_of (layout_of ap) k + 2*n + 1  
     start_of (layout_of ap) k + 2*n + 1   start_of (layout_of ap) (Suc k) 
      start_of (layout_of ap) (Suc k)  start_of (layout_of ap) (length ap)", auto)
   apply(subgoal_tac "start_of (layout_of ap) (Suc k) = 
  start_of  (layout_of ap)  k + 2*n + 16", simp)
   apply(simp add: start_of_suc_dec)
  apply(rule_tac start_of_all_le)
  done

lemma dec_state_all_le[simp]:
  "k < length ap; ap ! k = Dec n e; 
  (a, b)  set (shift (shift tdec_b (2 * n))
  (start_of (layout_of ap) k - Suc 0))
        b  start_of (layout_of ap) (length ap)"
  apply(subgoal_tac "2*n + start_of (layout_of ap) k + 16  start_of (layout_of ap) (length ap)  start_of (layout_of ap) k > 0")
   prefer 2
   apply(subgoal_tac "start_of (layout_of ap) (Suc k) = start_of (layout_of ap) k + 2*n + 16
                  start_of (layout_of ap) (Suc k)  start_of (layout_of ap) (length ap)")
    apply(simp, rule_tac conjI)
    apply(simp add: start_of_suc_dec)
   apply(rule_tac start_of_all_le)
  apply(auto simp: tdec_b_def shift.simps)
  done

lemma tms_any_less: 
  "k < length ap; (a, b)  set (tms_of ap ! k)  
  b  start_of (layout_of ap) (length ap)"
  apply(cases "ap!k", auto simp: tms_of.simps tpairs_of.simps ci.simps shift_append adjust.simps)
      apply(erule_tac findnth_state_all_le1, simp_all)
     apply(erule_tac inc_state_all_le, simp_all)
    apply(erule_tac findnth_state_all_le2, simp_all)
   apply(rule_tac start_of_all_le)
  apply(rule_tac start_of_all_le)
  done

lemma concat_in: "i < length (concat xs)  
  k < length xs. concat xs ! i  set (xs ! k)"
proof(induct xs rule: rev_induct)
  case (snoc x xs)
  then show ?case
    apply(cases "i < length (concat xs)", simp)
     apply(erule_tac exE, rule_tac x = k in exI)
     apply(simp add: nth_append)
    apply(rule_tac x = "length xs" in exI, simp)
    apply(simp add: nth_append)
    done 
qed auto

declare length_concat[simp]

lemma in_tms: "i < length (tm_of ap)   k < length ap. (tm_of ap ! i)  set (tms_of ap ! k)"
  apply(simp only: tm_of.simps)
  using concat_in[of i "tms_of ap"]
  apply(auto)
  done

lemma all_le_start_of: "list_all (λ(acn, s). 
  s  start_of (layout_of ap) (length ap)) (tm_of ap)"
  apply(simp only: list_all_length)
  apply(rule_tac allI, rule_tac impI)
  apply(drule_tac in_tms, auto elim: tms_any_less)
  done

lemma length_ci: 
  "k < length ap; length (ci ly y (ap ! k)) = 2 * qa
       layout_of ap ! k = qa"
  apply(cases "ap ! k")
    apply(auto simp: layout_of.simps ci.simps 
      length_of.simps tinc_b_def tdec_b_def length_findnth adjust.simps)
  done

lemma ci_even[intro]: "length (ci ly y i) mod 2 = 0"
  apply(cases i, auto simp: ci.simps length_findnth
      tinc_b_def adjust.simps tdec_b_def)
  done

lemma sum_list_ci_even[intro]: "sum_list (map (length  (λ(x, y). ci ly x y)) zs) mod 2 = 0"
proof(induct zs rule: rev_induct)
  case (snoc x xs)
  then show ?case 
    apply(cases x, simp)
    apply(subgoal_tac "length (ci ly (fst x) (snd x)) mod 2 = 0")
     apply(auto)
    done
qed (simp)

lemma zip_pre:
  "(length ys)  length ap 
  zip ys ap = zip ys (take (length ys) (ap::'a list))"
proof(induct ys arbitrary: ap)
  case (Cons a ys)
  from Cons(2) have z:"ap = aa # list  zip (a # ys) ap = zip (a # ys) (take (length (a # ys)) ap)"
    for aa list using Cons(1)[of list] by simp
  thus ?case by (cases ap;simp)
qed simp

lemma length_start_of_tm: "start_of (layout_of ap) (length ap) = Suc (length (tm_of ap)  div 2)"
  using tpa_states[of "tm_of ap"  "length ap" ap]
  by(simp add: tm_of.simps)

lemma list_all_add_6E[elim]: "list_all (λ(acn, s). s  Suc q) xs
         list_all (λ(acn, s). s  q + (2 * n + 6)) xs"
  by(auto simp: list_all_length)

lemma mopup_b_12[simp]: "length mopup_b = 12"
  by(simp add: mopup_b_def)

lemma mp_up_all_le: "list_all  (λ(acn, s). s  q + (2 * n + 6)) 
  [(R, Suc (Suc (2 * n + q))), (R, Suc (2 * n + q)), 
  (L, 5 + 2 * n + q), (W0, Suc (Suc (Suc (2 * n + q)))), (R, 4 + 2 * n + q),
  (W0, Suc (Suc (Suc (2 * n + q)))), (R, Suc (Suc (2 * n + q))),
  (W0, Suc (Suc (Suc (2 * n + q)))), (L, 5 + 2 * n + q),
  (L, 6 + 2 * n + q), (R, 0),  (L, 6 + 2 * n + q)]"
  by(auto)

lemma mopup_le6[simp]: "(a, b)  set (mopup_a n)  b  2 * n + 6"
  by(induct n, auto simp: mopup_a.simps)

lemma shift_le2[simp]: "(a, b)  set (shift (mopup n) x)
   b  (2 * x + length (mopup n)) div 2"
  apply(auto simp: mopup.simps shift_append shift.simps)
  apply(auto simp: mopup_b_def)
  done

lemma mopup_ge2[intro]: " 2  x + length (mopup n)"
  apply(simp add: mopup.simps)
  done

lemma mopup_even[intro]: " (2 * x + length (mopup n)) mod 2 = 0"
  by(auto simp: mopup.simps)

lemma mopup_div_2[simp]: "b  Suc x
           b  (2 * x + length (mopup n)) div 2"
  by(auto simp: mopup.simps)

lemma wf_tm_from_abacus: assumes "tp = tm_of ap"
  shows "tm_wf0 (tp @ shift (mopup n) (length tp div 2))"
proof -
  have "is_even (length (mopup n))" for n using tm_wf.simps by blast
  moreover have "(aa, ba)  set (mopup n)  ba  length (mopup n) div 2" for aa ba
    by (metis (no_types, lifting) add_cancel_left_right case_prodD tm_wf.simps wf_mopup)
  moreover have "(xset (tm_of ap). case x of (acn, s)  s  Suc (sum_list (layout_of ap))) 
           (a, b)  set (tm_of ap)  b  sum_list (layout_of ap) + length (mopup n) div 2"
    for a b s
    by (metis (no_types, lifting) add_Suc add_cancel_left_right case_prodD div_mult_mod_eq le_SucE mult_2_right not_numeral_le_zero tm_wf.simps trans_le_add1 wf_mopup)
  ultimately show ?thesis unfolding assms
    using length_start_of_tm[of ap] all_le_start_of[of ap] tm_wf.simps 
    by(auto simp: List.list_all_iff shift.simps)
qed

lemma wf_tm_from_recf:
  assumes compile: "tp = tm_of_rec recf"
  shows "tm_wf0 tp"
proof -
  obtain a b c where "rec_ci recf = (a, b, c)"
    by (metis prod_cases3)
  thus "?thesis"
    using compile
    using wf_tm_from_abacus[of "tm_of (a [+] dummy_abc b)" "(a [+] dummy_abc b)" b]
    by simp
qed

end

Theory Recs

(* Title: thys/Recs.thy
   Author: Christian Urban
*)
theory Recs
  imports Main
    "HOL-Library.Nat_Bijection"
    "HOL-Library.Discrete"
begin


text‹
  A more streamlined and cleaned-up version of Recursive
  Functions following

    A Course in Formal Languages, Automata and Groups
    I. M. Chiswell

  and

    Lecture on Undecidability
    Michael M. Wolf
›

declare One_nat_def[simp del]


lemma if_zero_one [simp]:
  "(if P then 1 else 0) = (0::nat)  ¬ P"
  "(0::nat) < (if P then 1 else 0) = P"
  "(if P then 0 else 1) = (if ¬P then 1 else (0::nat))"
  by (simp_all)

lemma nth:
  "(x # xs) ! 0 = x"
  "(x # y # xs) ! 1 = y"
  "(x # y # z # xs) ! 2 = z"
  "(x # y # z # u # xs) ! 3 = u"
  by (simp_all)


section ‹Some auxiliary lemmas about ∑› and ∏›

lemma setprod_atMost_Suc[simp]:
  "(i  Suc n. f i) = (i  n. f i) * f(Suc n)"
  by(simp add:atMost_Suc mult_ac)

lemma setprod_lessThan_Suc[simp]:
  "(i < Suc n. f i) = (i < n. f i) * f n"
  by (simp add:lessThan_Suc mult_ac)

lemma setsum_add_nat_ivl2: "n  p  
  sum f {..<n} + sum f {n..p} = sum f {..p::nat}"
  apply(subst sum.union_disjoint[symmetric])
     apply(auto simp add: ivl_disj_un_one)
  done

lemma setsum_eq_zero [simp]:
  fixes f::"nat  nat"
  shows "(i < n. f i) = 0  (i < n. f i = 0)"
    "(i  n. f i) = 0  (i  n. f i = 0)"
  by (auto)

lemma setprod_eq_zero [simp]:
  fixes f::"nat  nat"
  shows "(i < n. f i) = 0  (i < n. f i = 0)"
    "(i  n. f i) = 0  (i  n. f i = 0)"
  by (auto)

lemma setsum_one_less:
  fixes n::nat
  assumes "i < n. f i  1"
  shows "(i < n. f i)  n"
  using assms
  by (induct n) (auto)

lemma setsum_one_le:
  fixes n::nat
  assumes "i  n. f i  1"
  shows "(i  n. f i)  Suc n"
  using assms
  by (induct n) (auto)

lemma setsum_eq_one_le:
  fixes n::nat
  assumes "i  n. f i = 1"
  shows "(i  n. f i) = Suc n"
  using assms
  by (induct n) (auto)

lemma setsum_least_eq:
  fixes f::"nat  nat"
  assumes h0: "p  n"
  assumes h1: "i  {..<p}. f i = 1"
  assumes h2: "i  {p..n}. f i = 0"
  shows "(i  n. f i) = p"
proof -
  have eq_p: "(i  {..<p}. f i) = p"
    using h1 by (induct p) (simp_all)
  have eq_zero: "(i  {p..n}. f i) = 0"
    using h2 by auto
  have "(i  n. f i) = (i  {..<p}. f i) + (i  {p..n}. f i)"
    using h0 by (simp add: setsum_add_nat_ivl2)
  also have "... = (i  {..<p}. f i)" using eq_zero by simp
  finally show "(i  n. f i) = p" using eq_p by simp
qed

lemma nat_mult_le_one:
  fixes m n::nat
  assumes "m  1" "n  1"
  shows "m * n  1"
  using assms by (induct n) (auto)

lemma setprod_one_le:
  fixes f::"nat  nat"
  assumes "i  n. f i  1"
  shows "(i  n. f i)  1"
  using assms
  by (induct n) (auto intro: nat_mult_le_one)

lemma setprod_greater_zero:
  fixes f::"nat  nat"
  assumes "i  n. f i  0"
  shows "(i  n. f i)  0"
  using assms by (induct n) (auto)

lemma setprod_eq_one:
  fixes f::"nat  nat"
  assumes "i  n. f i = Suc 0"
  shows "(i  n. f i) = Suc 0"
  using assms by (induct n) (auto)

lemma setsum_cut_off_less:
  fixes f::"nat  nat"
  assumes h1: "m  n"
    and     h2: "i  {m..<n}. f i = 0"
  shows "(i < n. f i) = (i < m. f i)"
proof -
  have eq_zero: "(i  {m..<n}. f i) = 0"
    using h2 by auto
  have "(i < n. f i) = (i  {..<m}. f i) + (i  {m..<n}. f i)"
    using h1 by (metis atLeast0LessThan le0 sum.atLeastLessThan_concat)
  also have "... = (i  {..<m}. f i)" using eq_zero by simp
  finally show "(i < n. f i) = (i < m. f i)" by simp
qed

lemma setsum_cut_off_le:
  fixes f::"nat  nat"
  assumes h1: "m  n"
    and     h2: "i  {m..n}. f i = 0"
  shows "(i  n. f i) = (i < m. f i)"
proof -
  have eq_zero: "(i  {m..n}. f i) = 0"
    using h2 by auto
  have "(i  n. f i) = (i  {..<m}. f i) + (i  {m..n}. f i)"
    using h1 by (simp add: setsum_add_nat_ivl2)
  also have "... = (i  {..<m}. f i)" using eq_zero by simp
  finally show "(i  n. f i) = (i < m. f i)" by simp
qed

lemma setprod_one [simp]:
  fixes n::nat
  shows "(i < n. Suc 0) = Suc 0"
    "(i  n. Suc 0) = Suc 0"
  by (induct n) (simp_all)



section ‹Recursive Functions›

datatype recf =  Z
  |  S
  |  Id nat nat
  |  Cn nat recf "recf list"
  |  Pr nat recf recf
  |  Mn nat recf

fun arity :: "recf  nat"
  where
    "arity Z = 1"
  | "arity S = 1"
  | "arity (Id m n) = m"
  | "arity (Cn n f gs) = n"
  | "arity (Pr n f g) = Suc n"
  | "arity (Mn n f) = n"

text ‹Abbreviations for calculating the arity of the constructors›

abbreviation
  "CN f gs  Cn (arity (hd gs)) f gs"

abbreviation
  "PR f g  Pr (arity f) f g"

abbreviation
  "MN f  Mn (arity f - 1) f"

text ‹the evaluation function and termination relation›

fun rec_eval :: "recf  nat list  nat"
  where
    "rec_eval Z xs = 0"
  | "rec_eval S xs = Suc (xs ! 0)"
  | "rec_eval (Id m n) xs = xs ! n"
  | "rec_eval (Cn n f gs) xs = rec_eval f (map (λx. rec_eval x xs) gs)"
  | "rec_eval (Pr n f g) (0 # xs) = rec_eval f xs"
  | "rec_eval (Pr n f g) (Suc x # xs) =
     rec_eval g (x # (rec_eval (Pr n f g) (x # xs)) # xs)"
  | "rec_eval (Mn n f) xs = (LEAST x. rec_eval f (x # xs) = 0)"

inductive
  terminates :: "recf  nat list  bool"
  where
    termi_z: "terminates Z [n]"
  | termi_s: "terminates S [n]"
  | termi_id: "n < m; length xs = m  terminates (Id m n) xs"
  | termi_cn: "terminates f (map (λg. rec_eval g xs) gs);
              g  set gs. terminates g xs; length xs = n  terminates (Cn n f gs) xs"
  | termi_pr: " y < x. terminates g (y # (rec_eval (Pr n f g) (y # xs) # xs));
              terminates f xs;
              length xs = n
               terminates (Pr n f g) (x # xs)"
  | termi_mn: "length xs = n; terminates f (r # xs);
              rec_eval f (r # xs) = 0;
               i < r. terminates f (i # xs)  rec_eval f (i # xs) > 0  terminates (Mn n f) xs"


section ‹Arithmetic Functions›

text constn n› is the recursive function which computes
  natural number n›.
›
fun constn :: "nat  recf"
  where
    "constn 0 = Z"  |
    "constn (Suc n) = CN S [constn n]"

definition
  "rec_swap f = CN f [Id 2 1, Id 2 0]"

definition
  "rec_add = PR (Id 1 0) (CN S [Id 3 1])"

definition
  "rec_mult = PR Z (CN rec_add [Id 3 1, Id 3 2])"

definition
  "rec_power = rec_swap (PR (constn 1) (CN rec_mult [Id 3 1, Id 3 2]))"

definition
  "rec_fact_aux = PR (constn 1) (CN rec_mult [CN S [Id 3 0], Id 3 1])"

definition
  "rec_fact = CN rec_fact_aux [Id 1 0, Id 1 0]"

definition
  "rec_predecessor = CN (PR Z (Id 3 0)) [Id 1 0, Id 1 0]"

definition
  "rec_minus = rec_swap (PR (Id 1 0) (CN rec_predecessor [Id 3 1]))"

lemma constn_lemma [simp]:
  "rec_eval (constn n) xs = n"
  by (induct n) (simp_all)

lemma swap_lemma [simp]:
  "rec_eval (rec_swap f) [x, y] = rec_eval f [y, x]"
  by (simp add: rec_swap_def)

lemma add_lemma [simp]:
  "rec_eval rec_add [x, y] =  x + y"
  by (induct x) (simp_all add: rec_add_def)

lemma mult_lemma [simp]:
  "rec_eval rec_mult [x, y] = x * y"
  by (induct x) (simp_all add: rec_mult_def)

lemma power_lemma [simp]:
  "rec_eval rec_power [x, y] = x ^ y"
  by (induct y) (simp_all add: rec_power_def)

lemma fact_aux_lemma [simp]:
  "rec_eval rec_fact_aux [x, y] = fact x"
  by (induct x) (simp_all add: rec_fact_aux_def)

lemma fact_lemma [simp]:
  "rec_eval rec_fact [x] = fact x"
  by (simp add: rec_fact_def)

lemma pred_lemma [simp]:
  "rec_eval rec_predecessor [x] =  x - 1"
  by (induct x) (simp_all add: rec_predecessor_def)

lemma minus_lemma [simp]:
  "rec_eval rec_minus [x, y] = x - y"
  by (induct y) (simp_all add: rec_minus_def)


section ‹Logical functions›

text ‹
  The sign› function returns 1 when the input argument
  is greater than 0›.›

definition
  "rec_sign = CN rec_minus [constn 1, CN rec_minus [constn 1, Id 1 0]]"

definition
  "rec_not = CN rec_minus [constn 1, Id 1 0]"

text rec_eq› compares two arguments: returns 1›
  if they are equal; 0› otherwise.›
definition
  "rec_eq = CN rec_minus [CN (constn 1) [Id 2 0], CN rec_add [rec_minus, rec_swap rec_minus]]"

definition
  "rec_noteq = CN rec_not [rec_eq]"

definition
  "rec_conj = CN rec_sign [rec_mult]"

definition
  "rec_disj = CN rec_sign [rec_add]"

definition
  "rec_imp = CN rec_disj [CN rec_not [Id 2 0], Id 2 1]"

text @{term "rec_ifz [z, x, y]"} returns x if z is zero,
  y otherwise;  @{term "rec_if [z, x, y]"} returns x if z is *not*
  zero, y otherwise›

definition
  "rec_ifz = PR (Id 2 0) (Id 4 3)"

definition
  "rec_if = CN rec_ifz [CN rec_not [Id 3 0], Id 3 1, Id 3 2]"


lemma sign_lemma [simp]:
  "rec_eval rec_sign [x] = (if x = 0 then 0 else 1)"
  by (simp add: rec_sign_def)

lemma not_lemma [simp]:
  "rec_eval rec_not [x] = (if x = 0 then 1 else 0)"
  by (simp add: rec_not_def)

lemma eq_lemma [simp]:
  "rec_eval rec_eq [x, y] = (if x = y then 1 else 0)"
  by (simp add: rec_eq_def)

lemma noteq_lemma [simp]:
  "rec_eval rec_noteq [x, y] = (if x  y then 1 else 0)"
  by (simp add: rec_noteq_def)

lemma conj_lemma [simp]:
  "rec_eval rec_conj [x, y] = (if x = 0  y = 0 then 0 else 1)"
  by (simp add: rec_conj_def)

lemma disj_lemma [simp]:
  "rec_eval rec_disj [x, y] = (if x = 0  y = 0 then 0 else 1)"
  by (simp add: rec_disj_def)

lemma imp_lemma [simp]:
  "rec_eval rec_imp [x, y] = (if 0 < x  y = 0 then 0 else 1)"
  by (simp add: rec_imp_def)

lemma ifz_lemma [simp]:
  "rec_eval rec_ifz [z, x, y] = (if z = 0 then x else y)"
  by (cases z) (simp_all add: rec_ifz_def)

lemma if_lemma [simp]:
  "rec_eval rec_if [z, x, y] = (if 0 < z then x else y)"
  by (simp add: rec_if_def)

section ‹Less and Le Relations›

text rec_less› compares two arguments and returns 1› if
  the first is less than the second; otherwise returns 0›.›

definition
  "rec_less = CN rec_sign [rec_swap rec_minus]"

definition
  "rec_le = CN rec_disj [rec_less, rec_eq]"

lemma less_lemma [simp]:
  "rec_eval rec_less [x, y] = (if x < y then 1 else 0)"
  by (simp add: rec_less_def)

lemma le_lemma [simp]:
  "rec_eval rec_le [x, y] = (if (x  y) then 1 else 0)"
  by(simp add: rec_le_def)


section ‹Summation and Product Functions›

definition
  "rec_sigma1 f = PR (CN f [CN Z [Id 1 0], Id 1 0])
                     (CN rec_add [Id 3 1, CN f [CN S [Id 3 0], Id 3 2]])"

definition
  "rec_sigma2 f = PR (CN f [CN Z [Id 2 0], Id 2 0, Id 2 1])
                     (CN rec_add [Id 4 1, CN f [CN S [Id 4 0], Id 4 2, Id 4 3]])"

definition
  "rec_accum1 f = PR (CN f [CN Z [Id 1 0], Id 1 0])
                     (CN rec_mult [Id 3 1, CN f [CN S [Id 3 0], Id 3 2]])"

definition
  "rec_accum2 f = PR (CN f [CN Z [Id 2 0], Id 2 0, Id 2 1])
                     (CN rec_mult [Id 4 1, CN f [CN S [Id 4 0], Id 4 2, Id 4 3]])"

definition
  "rec_accum3 f = PR (CN f [CN Z [Id 3 0], Id 3 0, Id 3 1, Id 3 2])
                     (CN rec_mult [Id 5 1, CN f [CN S [Id 5 0], Id 5 2, Id 5 3, Id 5 4]])"


lemma sigma1_lemma [simp]:
  shows "rec_eval (rec_sigma1 f) [x, y] = ( z  x. rec_eval f [z, y])"
  by (induct x) (simp_all add: rec_sigma1_def)

lemma sigma2_lemma [simp]:
  shows "rec_eval (rec_sigma2 f) [x, y1, y2] = ( z  x. rec_eval f  [z, y1, y2])"
  by (induct x) (simp_all add: rec_sigma2_def)

lemma accum1_lemma [simp]:
  shows "rec_eval (rec_accum1 f) [x, y] = ( z  x. rec_eval f  [z, y])"
  by (induct x) (simp_all add: rec_accum1_def)

lemma accum2_lemma [simp]:
  shows "rec_eval (rec_accum2 f) [x, y1, y2] = ( z  x. rec_eval f  [z, y1, y2])"
  by (induct x) (simp_all add: rec_accum2_def)

lemma accum3_lemma [simp]:
  shows "rec_eval (rec_accum3 f) [x, y1, y2, y3] = ( z  x. (rec_eval f)  [z, y1, y2, y3])"
  by (induct x) (simp_all add: rec_accum3_def)


section ‹Bounded Quantifiers›

definition
  "rec_all1 f = CN rec_sign [rec_accum1 f]"

definition
  "rec_all2 f = CN rec_sign [rec_accum2 f]"

definition
  "rec_all3 f = CN rec_sign [rec_accum3 f]"

definition
  "rec_all1_less f = (let cond1 = CN rec_eq [Id 3 0, Id 3 1] in
                      let cond2 = CN f [Id 3 0, Id 3 2]
                      in CN (rec_all2 (CN rec_disj [cond1, cond2])) [Id 2 0, Id 2 0, Id 2 1])"

definition
  "rec_all2_less f = (let cond1 = CN rec_eq [Id 4 0, Id 4 1] in
                      let cond2 = CN f [Id 4 0, Id 4 2, Id 4 3] in
                      CN (rec_all3 (CN rec_disj [cond1, cond2])) [Id 3 0, Id 3 0, Id 3 1, Id 3 2])"

definition
  "rec_ex1 f = CN rec_sign [rec_sigma1 f]"

definition
  "rec_ex2 f = CN rec_sign [rec_sigma2 f]"


lemma ex1_lemma [simp]:
  "rec_eval (rec_ex1 f) [x, y] = (if (z  x. 0 < rec_eval f [z, y]) then 1 else 0)"
  by (simp add: rec_ex1_def)

lemma ex2_lemma [simp]:
  "rec_eval (rec_ex2 f) [x, y1, y2] = (if (z  x. 0 < rec_eval f [z, y1, y2]) then 1 else 0)"
  by (simp add: rec_ex2_def)

lemma all1_lemma [simp]:
  "rec_eval (rec_all1 f) [x, y] = (if (z  x. 0 < rec_eval f [z, y]) then 1 else 0)"
  by (simp add: rec_all1_def)

lemma all2_lemma [simp]:
  "rec_eval (rec_all2 f) [x, y1, y2] = (if (z  x. 0 < rec_eval f [z, y1, y2]) then 1 else 0)"
  by (simp add: rec_all2_def)

lemma all3_lemma [simp]:
  "rec_eval (rec_all3 f) [x, y1, y2, y3] = (if (z  x. 0 < rec_eval f [z, y1, y2, y3]) then 1 else 0)"
  by (simp add: rec_all3_def)

lemma all1_less_lemma [simp]:
  "rec_eval (rec_all1_less f) [x, y] = (if (z < x. 0 < rec_eval f [z, y]) then 1 else 0)"
  apply(auto simp add: Let_def rec_all1_less_def)
   apply (metis nat_less_le)+
  done

lemma all2_less_lemma [simp]:
  "rec_eval (rec_all2_less f) [x, y1, y2] = (if (z < x. 0 < rec_eval f [z, y1, y2]) then 1 else 0)"
  apply(auto simp add: Let_def rec_all2_less_def)
   apply(metis nat_less_le)+
  done

section ‹Quotients›

definition
  "rec_quo = (let lhs = CN S [Id 3 0] in
              let rhs = CN rec_mult [Id 3 2, CN S [Id 3 1]] in
              let cond = CN rec_eq [lhs, rhs] in
              let if_stmt = CN rec_if [cond, CN S [Id 3 1], Id 3 1]
              in PR Z if_stmt)"

fun Quo where
  "Quo x 0 = 0"
| "Quo x (Suc y) = (if (Suc y = x * (Suc (Quo x y))) then Suc (Quo x y) else Quo x y)"

lemma Quo0:
  shows "Quo 0 y = 0"
  by (induct y) (auto)

lemma Quo1:
  "x * (Quo x y)  y"
  by (induct y) (simp_all)

lemma Quo2:
  "b * (Quo b a) + a mod b = a"
  by (induct a) (auto simp add: mod_Suc)

lemma Quo3:
  "n * (Quo n m) = m - m mod n"
  using Quo2[of n m] by (auto)

lemma Quo4:
  assumes h: "0 < x"
  shows "y < x + x * Quo x y"
proof -
  have "x - (y mod x) > 0" using mod_less_divisor assms by auto
  then have "y < y + (x - (y mod x))" by simp
  then have "y < x + (y - (y mod x))" by simp
  then show "y < x + x * (Quo x y)" by (simp add: Quo3)
qed

lemma Quo_div:
  shows "Quo x y = y div x"
  by (metis Quo0 Quo1 Quo4 div_by_0 div_nat_eqI mult_Suc_right neq0_conv)

lemma Quo_rec_quo:
  shows "rec_eval rec_quo [y, x] = Quo x y"
  by (induct y) (simp_all add: rec_quo_def)

lemma quo_lemma [simp]:
  shows "rec_eval rec_quo [y, x] = y div x"
  by (simp add: Quo_div Quo_rec_quo)


section ‹Iteration›

definition
  "rec_iter f = PR (Id 1 0) (CN f [Id 3 1])"

fun Iter where
  "Iter f 0 = id"
| "Iter f (Suc n) = f  (Iter f n)"

lemma Iter_comm:
  "(Iter f n) (f x) = f ((Iter f n) x)"
  by (induct n) (simp_all)

lemma iter_lemma [simp]:
  "rec_eval (rec_iter f) [n, x] =  Iter (λx. rec_eval f [x]) n x"
  by (induct n) (simp_all add: rec_iter_def)


section ‹Bounded Maximisation›


fun BMax_rec where
  "BMax_rec R 0 = 0"
| "BMax_rec R (Suc n) = (if R (Suc n) then (Suc n) else BMax_rec R n)"

definition
  BMax_set :: "(nat  bool)  nat  nat"
  where
    "BMax_set R x = Max ({z. z  x  R z}  {0})"

lemma BMax_rec_eq1:
  "BMax_rec R x = (GREATEST z. (R z  z  x)  z = 0)"
  apply(induct x)
   apply(auto intro: Greatest_equality Greatest_equality[symmetric])
  apply(simp add: le_Suc_eq)
  by metis

lemma BMax_rec_eq2:
  "BMax_rec R x = Max ({z. z  x  R z}  {0})"
  apply(induct x)
   apply(auto intro: Max_eqI Max_eqI[symmetric])
  apply(simp add: le_Suc_eq)
  by metis

lemma BMax_rec_eq3:
  "BMax_rec R x = Max (Set.filter (λz. R z) {..x}  {0})"
  by (simp add: BMax_rec_eq2 Set.filter_def)

definition
  "rec_max1 f = PR Z (CN rec_ifz [CN f [CN S [Id 3 0], Id 3 2], CN S [Id 3 0], Id 3 1])"

lemma max1_lemma [simp]:
  "rec_eval (rec_max1 f) [x, y] = BMax_rec (λu. rec_eval f [u, y] = 0) x"
  by (induct x) (simp_all add: rec_max1_def)

definition
  "rec_max2 f = PR Z (CN rec_ifz [CN f [CN S [Id 4 0], Id 4 2, Id 4 3], CN S [Id 4 0], Id 4 1])"

lemma max2_lemma [simp]:
  "rec_eval (rec_max2 f) [x, y1, y2] = BMax_rec (λu. rec_eval f [u, y1, y2] = 0) x"
  by (induct x) (simp_all add: rec_max2_def)


section ‹Encodings using Cantor's pairing function›

text ‹
  We use Cantor's pairing function from Nat-Bijection.
  However, we need to prove that the formulation of the
  decoding function there is recursive. For this we first
  prove that we can extract the maximal triangle number
  using @{term prod_decode}.
›

abbreviation Max_triangle_aux where
  "Max_triangle_aux k z  fst (prod_decode_aux k z) + snd (prod_decode_aux k z)"

abbreviation Max_triangle where
  "Max_triangle z  Max_triangle_aux 0 z"

abbreviation
  "pdec1 z  fst (prod_decode z)"

abbreviation
  "pdec2 z  snd (prod_decode z)"

abbreviation
  "penc m n  prod_encode (m, n)"

lemma fst_prod_decode:
  "pdec1 z = z - triangle (Max_triangle z)"
  by (subst (3) prod_decode_inverse[symmetric])
    (simp add: prod_encode_def prod_decode_def split: prod.split)

lemma snd_prod_decode:
  "pdec2 z = Max_triangle z - pdec1 z"
  by (simp only: prod_decode_def)

lemma le_triangle:
  "m  triangle (n + m)"
  by (induct m) (simp_all)

lemma Max_triangle_triangle_le:
  "triangle (Max_triangle z)  z"
  by (subst (9) prod_decode_inverse[symmetric])
    (simp add: prod_decode_def prod_encode_def split: prod.split)

lemma Max_triangle_le:
  "Max_triangle z  z"
proof -
  have "Max_triangle z  triangle (Max_triangle z)"
    using le_triangle[of _ 0, simplified] by simp
  also have "...  z" by (rule Max_triangle_triangle_le)
  finally show "Max_triangle z  z" .
qed

lemma w_aux:
  "Max_triangle (triangle k + m) = Max_triangle_aux k m"
  by (simp add: prod_decode_def[symmetric] prod_decode_triangle_add)

lemma y_aux: "y  Max_triangle_aux y k"
  apply(induct k arbitrary: y rule: nat_less_induct)
  apply(subst (1 2) prod_decode_aux.simps)
  by(auto dest!:spec mp elim:Suc_leD)

lemma Max_triangle_greatest:
  "Max_triangle z = (GREATEST k. (triangle k  z  k  z)  k = 0)"
  apply(rule Greatest_equality[symmetric])
   apply(rule disjI1)
   apply(rule conjI)
    apply(rule Max_triangle_triangle_le)
   apply(rule Max_triangle_le)
  apply(erule disjE)
   apply(erule conjE)
   apply(subst (asm) (1) le_iff_add)
   apply(erule exE)
   apply(clarify)
   apply(simp only: w_aux)
   apply(rule y_aux)
  apply(simp)
  done


definition
  "rec_triangle = CN rec_quo [CN rec_mult [Id 1 0, S], constn 2]"

definition
  "rec_max_triangle =
       (let cond = CN rec_not [CN rec_le [CN rec_triangle [Id 2 0], Id 2 1]] in
        CN (rec_max1 cond) [Id 1 0, Id 1 0])"


lemma triangle_lemma [simp]:
  "rec_eval rec_triangle [x] = triangle x"
  by (simp add: rec_triangle_def triangle_def)

lemma max_triangle_lemma [simp]:
  "rec_eval rec_max_triangle [x] = Max_triangle x"
  by (simp add: Max_triangle_greatest rec_max_triangle_def Let_def BMax_rec_eq1)


text ‹Encodings for Products›

definition
  "rec_penc = CN rec_add [CN rec_triangle [CN rec_add [Id 2 0, Id 2 1]], Id 2 0]"

definition
  "rec_pdec1 = CN rec_minus [Id 1 0, CN rec_triangle [CN rec_max_triangle [Id 1 0]]]"

definition
  "rec_pdec2 = CN rec_minus [CN rec_max_triangle [Id 1 0], CN rec_pdec1 [Id 1 0]]"

lemma pdec1_lemma [simp]:
  "rec_eval rec_pdec1 [z] = pdec1 z"
  by (simp add: rec_pdec1_def fst_prod_decode)

lemma pdec2_lemma [simp]:
  "rec_eval rec_pdec2 [z] = pdec2 z"
  by (simp add: rec_pdec2_def snd_prod_decode)

lemma penc_lemma [simp]:
  "rec_eval rec_penc [m, n] = penc m n"
  by (simp add: rec_penc_def prod_encode_def)


text ‹Encodings of Lists›

fun
  lenc :: "nat list  nat"
  where
    "lenc [] = 0"
  | "lenc (x # xs) = penc (Suc x) (lenc xs)"

fun
  ldec :: "nat  nat  nat"
  where
    "ldec z 0 = (pdec1 z) - 1"
  | "ldec z (Suc n) = ldec (pdec2 z) n"

lemma pdec_zero_simps [simp]:
  "pdec1 0 = 0"
  "pdec2 0 = 0"
  by (simp_all add: prod_decode_def prod_decode_aux.simps)

lemma ldec_zero:
  "ldec 0 n = 0"
  by (induct n) (simp_all add: prod_decode_def prod_decode_aux.simps)

lemma list_encode_inverse:
  "ldec (lenc xs) n = (if n < length xs then xs ! n else 0)"
  by (induct xs arbitrary: n rule: lenc.induct)
    (auto simp add: ldec_zero nth_Cons split: nat.splits)

lemma lenc_length_le:
  "length xs  lenc xs"
  by (induct xs) (simp_all add: prod_encode_def)


text ‹Membership for the List Encoding›

fun inside :: "nat  nat  bool" where
  "inside z 0 = (0 < z)"
| "inside z (Suc n) = inside (pdec2 z) n"

definition enclen :: "nat  nat" where
  "enclen z = BMax_rec (λx. inside z (x - 1)) z"

lemma inside_False [simp]:
  "inside 0 n = False"
  by (induct n) (simp_all)

lemma inside_length [simp]:
  "inside (lenc xs) s = (s < length xs)"
proof(induct s arbitrary: xs)
  case 0
  then show ?case by (cases xs) (simp_all add: prod_encode_def)
next
  case (Suc s)
  then show ?case by (cases xs;auto)
qed

text ‹Length of Encoded Lists›

lemma enclen_length [simp]:
  "enclen (lenc xs) = length xs"
  unfolding enclen_def
  apply(simp add: BMax_rec_eq1)
  apply(rule Greatest_equality)
   apply(auto simp add: lenc_length_le)
  done

lemma enclen_penc [simp]:
  "enclen (penc (Suc x) (lenc xs)) = Suc (enclen (lenc xs))"
  by (simp only: lenc.simps[symmetric] enclen_length) (simp)

lemma enclen_zero [simp]:
  "enclen 0 = 0"
  by (simp add: enclen_def)


text ‹Recursive Definitions for List Encodings›

fun
  rec_lenc :: "recf list  recf"
  where
    "rec_lenc [] = Z"
  | "rec_lenc (f # fs) = CN rec_penc [CN S [f], rec_lenc fs]"

definition
  "rec_ldec = CN rec_predecessor [CN rec_pdec1 [rec_swap (rec_iter rec_pdec2)]]"

definition
  "rec_inside = CN rec_less [Z, rec_swap (rec_iter rec_pdec2)]"

definition
  "rec_enclen = CN (rec_max1 (CN rec_not [CN rec_inside [Id 2 1, CN rec_predecessor [Id 2 0]]])) [Id 1 0, Id 1 0]"

lemma ldec_iter:
  "ldec z n = pdec1 (Iter pdec2 n z) - 1"
  by (induct n arbitrary: z) (simp | subst Iter_comm)+

lemma inside_iter:
  "inside z n = (0 < Iter pdec2 n z)"
  by (induct n arbitrary: z) (simp | subst Iter_comm)+

lemma lenc_lemma [simp]:
  "rec_eval (rec_lenc fs) xs = lenc (map (λf. rec_eval f xs) fs)"
  by (induct fs) (simp_all)

lemma ldec_lemma [simp]:
  "rec_eval rec_ldec [z, n] = ldec z n"
  by (simp add: ldec_iter rec_ldec_def)

lemma inside_lemma [simp]:
  "rec_eval rec_inside [z, n] = (if inside z n then 1 else 0)"
  by (simp add: inside_iter rec_inside_def)

lemma enclen_lemma [simp]:
  "rec_eval rec_enclen [z] = enclen z"
  by (simp add: rec_enclen_def enclen_def)


end

Theory UF

(* Title: thys/UF.thy
   Author: Jian Xu, Xingyuan Zhang, and Christian Urban
   Modifications: Sebastiaan Joosten
*)

chapter ‹Construction of a Universal Function›

theory UF
  imports Rec_Def HOL.GCD Abacus
begin

text ‹
  This theory file constructs the Universal Function rec_F›, which is the UTM defined
  in terms of recursive functions. This rec_F› is essentially an 
  interpreter of Turing Machines. Once the correctness of rec_F› is established,
  UTM can easil be obtained by compling rec_F› into the corresponding Turing Machine.
›

section ‹Universal Function›

subsection ‹The construction of component functions›

text ‹
  The recursive function used to do arithmetic addition.
›
definition rec_add :: "recf"
  where
    "rec_add   Pr 1 (id 1 0) (Cn 3 s [id 3 2])"

text ‹
  The recursive function used to do arithmetic multiplication.
›
definition rec_mult :: "recf"
  where
    "rec_mult = Pr 1 z (Cn 3 rec_add [id 3 0, id 3 2])"

text ‹
  The recursive function used to do arithmetic precede.
›
definition rec_pred :: "recf"
  where
    "rec_pred = Cn 1 (Pr 1 z (id 3 1)) [id 1 0, id 1 0]"

text ‹
  The recursive function used to do arithmetic subtraction.
›
definition rec_minus :: "recf" 
  where
    "rec_minus = Pr 1 (id 1 0) (Cn 3 rec_pred [id 3 2])"

text constn n› is the recursive function which computes 
  nature number n›.
›
fun constn :: "nat  recf"
  where
    "constn 0 = z"  |
    "constn (Suc n) = Cn 1 s [constn n]"


text ‹
  Sign function, which returns 1 when the input argument is greater than 0›.
›
definition rec_sg :: "recf"
  where
    "rec_sg = Cn 1 rec_minus [constn 1, 
                  Cn 1 rec_minus [constn 1, id 1 0]]"

text rec_less› compares its two arguments, returns 1› if
  the first is less than the second; otherwise returns 0›.
›
definition rec_less :: "recf"
  where
    "rec_less = Cn 2 rec_sg [Cn 2 rec_minus [id 2 1, id 2 0]]"

text rec_not› inverse its argument: returns 1› when the
  argument is 0›; returns 0› otherwise.
›
definition rec_not :: "recf"
  where
    "rec_not = Cn 1 rec_minus [constn 1, id 1 0]"

text rec_eq› compares its two arguments: returns 1›
  if they are equal; return 0› otherwise.
›
definition rec_eq :: "recf"
  where
    "rec_eq = Cn 2 rec_minus [Cn 2 (constn 1) [id 2 0], 
             Cn 2 rec_add [Cn 2 rec_minus [id 2 0, id 2 1], 
               Cn 2 rec_minus [id 2 1, id 2 0]]]"

text rec_conj› computes the conjunction of its two arguments, 
  returns 1› if both of them are non-zero; returns 0›
  otherwise.
›
definition rec_conj :: "recf"
  where
    "rec_conj = Cn 2 rec_sg [Cn 2 rec_mult [id 2 0, id 2 1]] "

text rec_disj› computes the disjunction of its two arguments, 
  returns 0› if both of them are zero; returns 0›
  otherwise.
›
definition rec_disj :: "recf"
  where
    "rec_disj = Cn 2 rec_sg [Cn 2 rec_add [id 2 0, id 2 1]]"


text ‹
  Computes the arity of recursive function.
›

fun arity :: "recf  nat"
  where
    "arity z = 1" 
  | "arity s = 1"
  | "arity (id m n) = m"
  | "arity (Cn n f gs) = n"
  | "arity (Pr n f g) = Suc n"
  | "arity (Mn n f) = n"

text get_fstn_args n (Suc k)› returns
  [id n 0, id n 1, id n 2, …, id n k]›, 
  the effect of which is to take out the first Suc k› 
  arguments out of the n› input arguments.
›

fun get_fstn_args :: "nat   nat  recf list"
  where
    "get_fstn_args n 0 = []"
  | "get_fstn_args n (Suc y) = get_fstn_args n y @ [id n y]"

text rec_sigma f› returns the recursive functions which 
  sums up the results of f›:
  \[
  (rec\_sigma f)(x, y) = f(x, 0) + f(x, 1) + \cdots + f(x, y)
  \]
›
fun rec_sigma :: "recf  recf"
  where
    "rec_sigma rf = 
       (let vl = arity rf in 
          Pr (vl - 1) (Cn (vl - 1) rf (get_fstn_args (vl - 1) (vl - 1) @ 
                    [Cn (vl - 1) (constn 0) [id (vl - 1) 0]])) 
             (Cn (Suc vl) rec_add [id (Suc vl) vl, 
                    Cn (Suc vl) rf (get_fstn_args (Suc vl) (vl - 1) 
                        @ [Cn (Suc vl) s [id (Suc vl) (vl - 1)]])]))"

text rec_exec› is the interpreter function for
  reursive functions. The function is defined such that 
  it always returns meaningful results for primitive recursive 
  functions.
›

declare rec_exec.simps[simp del] constn.simps[simp del]

text ‹
  Correctness of rec_add›.
›
lemma add_lemma: " x y. rec_exec rec_add [x, y] =  x + y"
  by(induct_tac y, auto simp: rec_add_def rec_exec.simps)

text ‹
  Correctness of rec_mult›.
›
lemma mult_lemma: " x y. rec_exec rec_mult [x, y] = x * y"
  by(induct_tac y, auto simp: rec_mult_def rec_exec.simps add_lemma)

text ‹
  Correctness of rec_pred›.
›
lemma pred_lemma: " x. rec_exec rec_pred [x] =  x - 1"
  by(induct_tac x, auto simp: rec_pred_def rec_exec.simps)

text ‹
  Correctness of rec_minus›.
›
lemma minus_lemma: " x y. rec_exec rec_minus [x, y] = x - y"
  by(induct_tac y, auto simp: rec_exec.simps rec_minus_def pred_lemma)

text ‹
  Correctness of rec_sg›.
›
lemma sg_lemma: " x. rec_exec rec_sg [x] = (if x = 0 then 0 else 1)"
  by(auto simp: rec_sg_def minus_lemma rec_exec.simps constn.simps)

text ‹
  Correctness of constn›.
›
lemma constn_lemma: "rec_exec (constn n) [x] = n"
  by(induct n, auto simp: rec_exec.simps constn.simps)

text ‹
  Correctness of rec_less›.
›
lemma less_lemma: " x y. rec_exec rec_less [x, y] = 
  (if x < y then 1 else 0)"
  by(induct_tac y, auto simp: rec_exec.simps 
      rec_less_def minus_lemma sg_lemma)

text ‹
  Correctness of rec_not›.
›
lemma not_lemma: 
  " x. rec_exec rec_not [x] = (if x = 0 then 1 else 0)"
  by(induct_tac x, auto simp: rec_exec.simps rec_not_def
      constn_lemma minus_lemma)

text ‹
  Correctness of rec_eq›.
›
lemma eq_lemma: " x y. rec_exec rec_eq [x, y] = (if x = y then 1 else 0)"
  by(induct_tac y, auto simp: rec_exec.simps rec_eq_def constn_lemma add_lemma minus_lemma)

text ‹
  Correctness of rec_conj›.
›
lemma conj_lemma: " x y. rec_exec rec_conj [x, y] = (if x = 0  y = 0 then 0 
                                                       else 1)"
  by(induct_tac y, auto simp: rec_exec.simps sg_lemma rec_conj_def mult_lemma)

text ‹
  Correctness of rec_disj›.
›
lemma disj_lemma: " x y. rec_exec rec_disj [x, y] = (if x = 0  y = 0 then 0
                                                     else 1)"
  by(induct_tac y, auto simp: rec_disj_def sg_lemma add_lemma rec_exec.simps)


text primrec recf n› is true iff 
  recf› is a primitive recursive function 
  with arity n›.
›
inductive primerec :: "recf  nat  bool"
  where
    prime_z[intro]:  "primerec z (Suc 0)" |
    prime_s[intro]:  "primerec s (Suc 0)" |
    prime_id[intro!]: "n < m  primerec (id m n) m" |
    prime_cn[intro!]: "primerec f k; length gs = k; 
   i < length gs. primerec (gs ! i) m; m = n 
   primerec (Cn n f gs) m" |
    prime_pr[intro!]: "primerec f n; 
  primerec g (Suc (Suc n)); m = Suc n 
   primerec (Pr n f g) m" 

inductive_cases prime_cn_reverse'[elim]: "primerec (Cn n f gs) n" 
inductive_cases prime_mn_reverse: "primerec (Mn n f) m" 
inductive_cases prime_z_reverse[elim]: "primerec z n"
inductive_cases prime_s_reverse[elim]: "primerec s n"
inductive_cases prime_id_reverse[elim]: "primerec (id m n) k"
inductive_cases prime_cn_reverse[elim]: "primerec (Cn n f gs) m"
inductive_cases prime_pr_reverse[elim]: "primerec (Pr n f g) m"

declare mult_lemma[simp] add_lemma[simp] pred_lemma[simp] 
  minus_lemma[simp] sg_lemma[simp] constn_lemma[simp] 
  less_lemma[simp] not_lemma[simp] eq_lemma[simp]
  conj_lemma[simp] disj_lemma[simp]

text Sigma› is the logical specification of 
  the recursive function rec_sigma›.
›
function Sigma :: "(nat list  nat)  nat list  nat"
  where
    "Sigma g xs = (if last xs = 0 then g xs
                 else (Sigma g (butlast xs @ [last xs - 1]) +
                       g xs)) "
  by pat_completeness auto
termination
proof
  show "wf (measure (λ (f, xs). last xs))" by auto
next
  fix g xs
  assume "last (xs::nat list)  0"
  thus "((g, butlast xs @ [last xs - 1]), g, xs)  
                    measure (λ(f, xs). last xs)"
    by auto
qed

declare rec_exec.simps[simp del] get_fstn_args.simps[simp del]
  arity.simps[simp del] Sigma.simps[simp del]
  rec_sigma.simps[simp del]

lemma rec_pr_Suc_simp_rewrite: 
  "rec_exec (Pr n f g) (xs @ [Suc x]) =
                       rec_exec g (xs @ [x] @ 
                        [rec_exec (Pr n f g) (xs @ [x])])"
  by(simp add: rec_exec.simps)

lemma Sigma_0_simp_rewrite:
  "Sigma f (xs @ [0]) = f (xs @ [0])"
  by(simp add: Sigma.simps)

lemma Sigma_Suc_simp_rewrite: 
  "Sigma f (xs @ [Suc x]) = Sigma f (xs @ [x]) + f (xs @ [Suc x])"
  by(simp add: Sigma.simps)

lemma append_access_1[simp]: "(xs @ ys) ! (Suc (length xs)) = ys ! 1"
  by(simp add: nth_append)

lemma get_fstn_args_take: "length xs = m; n  m  
  map (λ f. rec_exec f xs) (get_fstn_args m n)= take n xs"
proof(induct n)
  case 0 thus "?case"
    by(simp add: get_fstn_args.simps)
next
  case (Suc n) thus "?case"
    by(simp add: get_fstn_args.simps rec_exec.simps 
        take_Suc_conv_app_nth)
qed

lemma arity_primerec[simp]: "primerec f n  arity f = n"
  apply(cases f)
       apply(auto simp: arity.simps )
  apply(erule_tac prime_mn_reverse)
  done

lemma rec_sigma_Suc_simp_rewrite: 
  "primerec f (Suc (length xs))
     rec_exec (rec_sigma f) (xs @ [Suc x]) = 
    rec_exec (rec_sigma f) (xs @ [x]) + rec_exec f (xs @ [Suc x])"
  apply(induct x)
   apply(auto simp: rec_sigma.simps Let_def rec_pr_Suc_simp_rewrite
      rec_exec.simps get_fstn_args_take)
  done      

text ‹
  The correctness of rec_sigma› with respect to its specification.
›
lemma sigma_lemma: 
  "primerec rg (Suc (length xs))
      rec_exec (rec_sigma rg) (xs @ [x]) = Sigma (rec_exec rg) (xs @ [x])"
  apply(induct x)
   apply(auto simp: rec_exec.simps rec_sigma.simps Let_def 
      get_fstn_args_take Sigma_0_simp_rewrite
      Sigma_Suc_simp_rewrite) 
  done

text rec_accum f (x1, x2, …, xn, k) = 
           f(x1, x2, …, xn, 0) * 
           f(x1, x2, …, xn, 1) *
               … 
           f(x1, x2, …, xn, k)›
fun rec_accum :: "recf  recf"
  where
    "rec_accum rf = 
       (let vl = arity rf in 
          Pr (vl - 1) (Cn (vl - 1) rf (get_fstn_args (vl - 1) (vl - 1) @ 
                     [Cn (vl - 1) (constn 0) [id (vl - 1) 0]])) 
             (Cn (Suc vl) rec_mult [id (Suc vl) (vl), 
                    Cn (Suc vl) rf (get_fstn_args (Suc vl) (vl - 1) 
                      @ [Cn (Suc vl) s [id (Suc vl) (vl - 1)]])]))"

text Accum› is the formal specification of rec_accum›.
›
function Accum :: "(nat list  nat)  nat list  nat"
  where
    "Accum f xs = (if last xs = 0 then f xs 
                     else (Accum f (butlast xs @ [last xs - 1]) *
                       f xs))"
  by pat_completeness auto
termination
proof
  show "wf (measure (λ (f, xs). last xs))"
    by auto
next
  fix f xs
  assume "last xs  (0::nat)"
  thus "((f, butlast xs @ [last xs - 1]), f, xs)  
            measure (λ(f, xs). last xs)"
    by auto
qed

lemma rec_accum_Suc_simp_rewrite: 
  "primerec f (Suc (length xs))
     rec_exec (rec_accum f) (xs @ [Suc x]) = 
    rec_exec (rec_accum f) (xs @ [x]) * rec_exec f (xs @ [Suc x])"
  apply(induct x)
   apply(auto simp: rec_sigma.simps Let_def rec_pr_Suc_simp_rewrite
      rec_exec.simps get_fstn_args_take)
  done  

text ‹
  The correctness of rec_accum› with respect to its specification.
›
lemma accum_lemma :
  "primerec rg (Suc (length xs))
      rec_exec (rec_accum rg) (xs @ [x]) = Accum (rec_exec rg) (xs @ [x])"
  apply(induct x)
   apply(auto simp: rec_exec.simps rec_sigma.simps Let_def 
      get_fstn_args_take)
  done

declare rec_accum.simps [simp del]

text rec_all t f (x1, x2, …, xn)› 
  computes the charactrization function of the following FOL formula:
  (∀ x ≤ t(x1, x2, …, xn). (f(x1, x2, …, xn, x) > 0))›
fun rec_all :: "recf  recf  recf"
  where
    "rec_all rt rf = 
    (let vl = arity rf in
       Cn (vl - 1) rec_sg [Cn (vl - 1) (rec_accum rf) 
                 (get_fstn_args (vl - 1) (vl - 1) @ [rt])])"

lemma rec_accum_ex:
  assumes "primerec rf (Suc (length xs))"
  shows "(rec_exec (rec_accum rf) (xs @ [x]) = 0) = 
         ( t  x. rec_exec rf (xs @ [t]) = 0)"
proof(induct x)
  case (Suc x)
  with assms show ?case 
    apply(auto simp add: rec_exec.simps rec_accum.simps get_fstn_args_take)
     apply(rename_tac t ta)
     apply(rule_tac x = ta in exI, simp)
    apply(case_tac "t = Suc x", simp_all)
    apply(rule_tac x = t in exI, simp) done
qed (insert assms,auto simp add: rec_exec.simps rec_accum.simps get_fstn_args_take)


text ‹
  The correctness of rec_all›.
›
lemma all_lemma: 
  "primerec rf (Suc (length xs));
    primerec rt (length xs)
   rec_exec (rec_all rt rf) xs = (if ( x  (rec_exec rt xs). 0 < rec_exec rf (xs @ [x])) then 1
                                                                                              else 0)"
  apply(auto simp: rec_all.simps)
   apply(simp add: rec_exec.simps map_append get_fstn_args_take split: if_splits)
   apply(drule_tac x = "rec_exec rt xs" in rec_accum_ex)
   apply(cases "rec_exec (rec_accum rf) (xs @ [rec_exec rt xs]) = 0", simp_all)
   apply force
  apply(simp add: rec_exec.simps map_append get_fstn_args_take)
  apply(drule_tac x = "rec_exec rt xs" in rec_accum_ex)
  apply(cases "rec_exec (rec_accum rf) (xs @ [rec_exec rt xs]) = 0")
   apply force+
  done

text rec_ex t f (x1, x2, …, xn)› 
  computes the charactrization function of the following FOL formula:
  (∃ x ≤ t(x1, x2, …, xn). (f(x1, x2, …, xn, x) > 0))›
fun rec_ex :: "recf  recf  recf"
  where
    "rec_ex rt rf = 
       (let vl = arity rf in 
         Cn (vl - 1) rec_sg [Cn (vl - 1) (rec_sigma rf) 
                  (get_fstn_args (vl - 1) (vl - 1) @ [rt])])"

lemma rec_sigma_ex: 
  assumes "primerec rf (Suc (length xs))"
  shows "(rec_exec (rec_sigma rf) (xs @ [x]) = 0) = 
                          ( t  x. rec_exec rf (xs @ [t]) = 0)"
proof(induct x)
  case (Suc x)
  from Suc assms show ?case
    by(auto simp add: rec_exec.simps rec_sigma.simps 
        get_fstn_args_take elim:le_SucE)
qed (insert assms,auto simp: get_fstn_args_take rec_exec.simps rec_sigma.simps)

text ‹
  The correctness of ex_lemma›.
›
lemma ex_lemma:"
  primerec rf (Suc (length xs));
   primerec rt (length xs)
 (rec_exec (rec_ex rt rf) xs =
    (if ( x  (rec_exec rt xs). 0 <rec_exec rf (xs @ [x])) then 1
     else 0))"
  apply(auto simp: rec_exec.simps get_fstn_args_take split: if_splits)
   apply(drule_tac x = "rec_exec rt xs" in rec_sigma_ex, simp)
  apply(drule_tac x = "rec_exec rt xs" in rec_sigma_ex, simp)
  done

text ‹
  Definition of Min[R]› on page 77 of Boolos's book.
›

fun Minr :: "(nat list  bool)  nat list  nat  nat"
  where "Minr Rr xs w = (let setx = {y | y. (y  w)  Rr (xs @ [y])} in 
                        if (setx = {}) then (Suc w)
                                       else (Min setx))"

declare Minr.simps[simp del] rec_all.simps[simp del]

text ‹
  The following is a set of auxilliary lemmas about Minr›.
›
lemma Minr_range: "Minr Rr xs w  w  Minr Rr xs w = Suc w"
  apply(auto simp: Minr.simps)
  apply(subgoal_tac "Min {x. x  w  Rr (xs @ [x])}  x")
   apply(erule_tac order_trans, simp)
  apply(rule_tac Min_le, auto)
  done

lemma expand_conj_in_set: "{x. x  Suc w  Rr (xs @ [x])}
    = (if Rr (xs @ [Suc w]) then insert (Suc w) 
                              {x. x  w  Rr (xs @ [x])}
      else {x. x  w  Rr (xs @ [x])})"
  by (auto elim:le_SucE)

lemma Minr_strip_Suc[simp]: "Minr Rr xs w  w  Minr Rr xs (Suc w) = Minr Rr xs w"
  by(cases "xw. ¬ Rr (xs @ [x])",auto simp add: Minr.simps expand_conj_in_set)

lemma x_empty_set[simp]: "xw. ¬ Rr (xs @ [x])   
                           {x. x  w  Rr (xs @ [x])} = {} "
  by auto

lemma Minr_is_Suc[simp]: "Minr Rr xs w = Suc w; Rr (xs @ [Suc w])  
                                       Minr Rr xs (Suc w) = Suc w"
  apply(simp add: Minr.simps expand_conj_in_set)
  apply(cases "xw. ¬ Rr (xs @ [x])", auto)
  done

lemma Minr_is_Suc_Suc[simp]: "Minr Rr xs w = Suc w; ¬ Rr (xs @ [Suc w])  
                                   Minr Rr xs (Suc w) = Suc (Suc w)"
  apply(simp add: Minr.simps expand_conj_in_set)
  apply(cases "xw. ¬ Rr (xs @ [x])", auto)
  apply(subgoal_tac "Min {x. x  w  Rr (xs @ [x])}  
                                {x. x  w  Rr (xs @ [x])}", simp)
  apply(rule_tac Min_in, auto)
  done

lemma Minr_Suc_simp: 
  "Minr Rr xs (Suc w) = 
      (if Minr Rr xs w  w then Minr Rr xs w
       else if (Rr (xs @ [Suc w])) then (Suc w)
       else Suc (Suc w))"
  by(insert Minr_range[of Rr xs w], auto)

text rec_Minr› is the recursive function 
  used to implement Minr›:
  if Rr› is implemented by a recursive function recf›,
  then rec_Minr recf› is the recursive function used to 
  implement Minr Rr›
fun rec_Minr :: "recf  recf"
  where
    "rec_Minr rf = 
     (let vl = arity rf
      in let rq = rec_all (id vl (vl - 1)) (Cn (Suc vl) 
              rec_not [Cn (Suc vl) rf 
                    (get_fstn_args (Suc vl) (vl - 1) @
                                        [id (Suc vl) (vl)])]) 
      in  rec_sigma rq)"

lemma length_getpren_params[simp]: "length (get_fstn_args m n) = n"
  by(induct n, auto simp: get_fstn_args.simps)

lemma length_app:
  "(length (get_fstn_args (arity rf - Suc 0)
                           (arity rf - Suc 0)
   @ [Cn (arity rf - Suc 0) (constn 0)
           [recf.id (arity rf - Suc 0) 0]]))
    = (Suc (arity rf - Suc 0))"
  apply(simp)
  done

lemma primerec_accum: "primerec (rec_accum rf) n  primerec rf n"
  apply(auto simp: rec_accum.simps Let_def)
  apply(erule_tac prime_pr_reverse, simp)
  apply(erule_tac prime_cn_reverse, simp only: length_app)
  done

lemma primerec_all: "primerec (rec_all rt rf) n 
                       primerec rt n  primerec rf (Suc n)"
  apply(simp add: rec_all.simps Let_def)
  apply(erule_tac prime_cn_reverse, simp)
  apply(erule_tac prime_cn_reverse, simp)
  apply(erule_tac x = n in allE, simp add: nth_append primerec_accum)
  done

declare numeral_3_eq_3[simp]

lemma primerec_rec_pred_1[intro]: "primerec rec_pred (Suc 0)"
  apply(simp add: rec_pred_def)
  apply(rule_tac prime_cn, auto dest:less_2_cases[unfolded numeral One_nat_def])
  done

lemma primerec_rec_minus_2[intro]: "primerec rec_minus (Suc (Suc 0))"
  apply(auto simp: rec_minus_def)
  done

lemma primerec_constn_1[intro]: "primerec (constn n) (Suc 0)"
  apply(induct n)
   apply(auto simp: constn.simps)
  done

lemma primerec_rec_sg_1[intro]: "primerec rec_sg (Suc 0)" 
  apply(simp add: rec_sg_def)
  apply(rule_tac k = "Suc (Suc 0)" in prime_cn)
     apply(auto)
  apply(auto dest!:less_2_cases[unfolded numeral One_nat_def])
    apply( auto)
  done

lemma primerec_getpren[elim]: "i < n; n  m  primerec (get_fstn_args m n ! i) m"
  apply(induct n, auto simp: get_fstn_args.simps)
  apply(cases "i = n", auto simp: nth_append intro: prime_id)
  done

lemma primerec_rec_add_2[intro]: "primerec rec_add (Suc (Suc 0))"
  apply(simp add: rec_add_def)
  apply(rule_tac prime_pr, auto)
  done

lemma primerec_rec_mult_2[intro]:"primerec rec_mult (Suc (Suc 0))"
  apply(simp add: rec_mult_def )
  apply(rule_tac prime_pr, auto)
  using less_2_cases numeral_2_eq_2 by fastforce

lemma primerec_ge_2_elim[elim]: "primerec rf n; n  Suc (Suc 0)    
                        primerec (rec_accum rf) n"
  apply(auto simp: rec_accum.simps)
   apply(simp add: nth_append, auto dest!:less_2_cases[unfolded numeral One_nat_def])
    apply force
   apply force
  apply(auto simp: nth_append)
  done

lemma primerec_all_iff: 
  "primerec rt n; primerec rf (Suc n); n > 0  
                                 primerec (rec_all rt rf) n"
  apply(simp add: rec_all.simps, auto)
    apply(auto, simp add: nth_append, auto)
  done

lemma primerec_rec_not_1[intro]: "primerec rec_not (Suc 0)"
  apply(simp add: rec_not_def)
  apply(rule prime_cn, auto dest!:less_2_cases[unfolded numeral One_nat_def])
  done

lemma Min_false1[simp]: "¬ Min {uu. uu  w  0 < rec_exec rf (xs @ [uu])}  w;
       x  w; 0 < rec_exec rf (xs @ [x])
        False"
  apply(subgoal_tac "finite {uu. uu  w  0 < rec_exec rf (xs @ [uu])}")
   apply(subgoal_tac "{uu. uu  w  0 < rec_exec rf (xs @ [uu])}  {}")
    apply(simp add: Min_le_iff, simp)
   apply(rule_tac x = x in exI, simp)
  apply(simp)
  done

lemma sigma_minr_lemma: 
  assumes prrf:  "primerec rf (Suc (length xs))"
  shows "UF.Sigma (rec_exec (rec_all (recf.id (Suc (length xs)) (length xs))
     (Cn (Suc (Suc (length xs))) rec_not
      [Cn (Suc (Suc (length xs))) rf (get_fstn_args (Suc (Suc (length xs))) 
       (length xs) @ [recf.id (Suc (Suc (length xs))) (Suc (length xs))])])))
      (xs @ [w]) =
       Minr (λargs. 0 < rec_exec rf args) xs w"
proof(induct w)
  let ?rt = "(recf.id (Suc (length xs)) ((length xs)))"
  let ?rf = "(Cn (Suc (Suc (length xs))) 
    rec_not [Cn (Suc (Suc (length xs))) rf 
    (get_fstn_args (Suc (Suc (length xs))) (length xs) @ 
                [recf.id (Suc (Suc (length xs))) 
    (Suc ((length xs)))])])"
  let ?rq = "(rec_all ?rt ?rf)"
  have prrf: "primerec ?rf (Suc (length (xs @ [0]))) 
        primerec ?rt (length (xs @ [0]))"
    apply(auto simp: prrf nth_append)+
    done
  show "Sigma (rec_exec (rec_all ?rt ?rf)) (xs @ [0])
       = Minr (λargs. 0 < rec_exec rf args) xs 0"
    apply(simp add: Sigma.simps)
    apply(simp only: prrf all_lemma,  
        auto simp: rec_exec.simps get_fstn_args_take Minr.simps)
    apply(rule_tac Min_eqI, auto)
    done
next
  fix w
  let ?rt = "(recf.id (Suc (length xs)) ((length xs)))"
  let ?rf = "(Cn (Suc (Suc (length xs))) 
    rec_not [Cn (Suc (Suc (length xs))) rf 
    (get_fstn_args (Suc (Suc (length xs))) (length xs) @ 
                [recf.id (Suc (Suc (length xs))) 
    (Suc ((length xs)))])])"
  let ?rq = "(rec_all ?rt ?rf)"
  assume ind:
    "Sigma (rec_exec (rec_all ?rt ?rf)) (xs @ [w]) = Minr (λargs. 0 < rec_exec rf args) xs w"
  have prrf: "primerec ?rf (Suc (length (xs @ [Suc w]))) 
        primerec ?rt (length (xs @ [Suc w]))"
    apply(auto simp: prrf nth_append)+
    done
  show "UF.Sigma (rec_exec (rec_all ?rt ?rf))
         (xs @ [Suc w]) =
        Minr (λargs. 0 < rec_exec rf args) xs (Suc w)"
    apply(auto simp: Sigma_Suc_simp_rewrite ind Minr_Suc_simp)
       apply(simp_all only: prrf all_lemma)
       apply(auto simp: rec_exec.simps get_fstn_args_take Let_def Minr.simps split: if_splits)
       apply(drule_tac Min_false1, simp, simp, simp)
      apply (metis le_SucE neq0_conv)
     apply(drule_tac Min_false1, simp, simp, simp)
    apply(drule_tac Min_false1, simp, simp, simp)
    done
qed

text ‹
  The correctness of rec_Minr›.
›
lemma Minr_lemma: "
  primerec rf (Suc (length xs)) 
      rec_exec (rec_Minr rf) (xs @ [w]) = 
            Minr (λ args. (0 < rec_exec rf args)) xs w"
proof -
  let ?rt = "(recf.id (Suc (length xs)) ((length xs)))"
  let ?rf = "(Cn (Suc (Suc (length xs))) 
    rec_not [Cn (Suc (Suc (length xs))) rf 
    (get_fstn_args (Suc (Suc (length xs))) (length xs) @ 
                [recf.id (Suc (Suc (length xs))) 
    (Suc ((length xs)))])])"
  let ?rq = "(rec_all ?rt ?rf)"
  assume h: "primerec rf (Suc (length xs))"
  have h1: "primerec ?rq (Suc (length xs))"
    apply(rule_tac primerec_all_iff)
      apply(auto simp: h nth_append)+
    done
  moreover have "arity rf = Suc (length xs)"
    using h by auto
  ultimately show "rec_exec (rec_Minr rf) (xs @ [w]) = 
    Minr (λ args. (0 < rec_exec rf args)) xs w"
    apply(simp add: arity.simps Let_def sigma_lemma all_lemma)
    apply(rule_tac  sigma_minr_lemma)
    apply(simp add: h)
    done
qed

text rec_le› is the comparasion function 
  which compares its two arguments, testing whether the 
  first is less or equal to the second.
›
definition rec_le :: "recf"
  where
    "rec_le = Cn (Suc (Suc 0)) rec_disj [rec_less, rec_eq]"

text ‹
  The correctness of rec_le›.
›
lemma le_lemma: 
  "x y. rec_exec rec_le [x, y] = (if (x  y) then 1 else 0)"
  by(auto simp: rec_le_def rec_exec.simps)

text ‹
  Definition of Max[Rr]› on page 77 of Boolos's book.
›

fun Maxr :: "(nat list  bool)  nat list  nat  nat"
  where
    "Maxr Rr xs w = (let setx = {y. y  w  Rr (xs @[y])} in 
                  if setx = {} then 0
                  else Max setx)"

text rec_maxr› is the recursive function 
  used to implementation Maxr›.
›
fun rec_maxr :: "recf  recf"
  where
    "rec_maxr rr = (let vl = arity rr in 
                  let rt = id (Suc vl) (vl - 1) in
                  let rf1 = Cn (Suc (Suc vl)) rec_le 
                    [id (Suc (Suc vl)) 
                     ((Suc vl)), id (Suc (Suc vl)) (vl)] in
                  let rf2 = Cn (Suc (Suc vl)) rec_not 
                      [Cn (Suc (Suc vl)) 
                           rr (get_fstn_args (Suc (Suc vl)) 
                            (vl - 1) @ 
                             [id (Suc (Suc vl)) ((Suc vl))])] in
                  let rf = Cn (Suc (Suc vl)) rec_disj [rf1, rf2] in
                  let Qf = Cn (Suc vl) rec_not [rec_all rt rf]
                  in Cn vl (rec_sigma Qf) (get_fstn_args vl vl @
                                                         [id vl (vl - 1)]))"

declare rec_maxr.simps[simp del] Maxr.simps[simp del] 
declare le_lemma[simp]

declare numeral_2_eq_2[simp]

lemma primerec_rec_disj_2[intro]: "primerec rec_disj (Suc (Suc 0))"
  apply(simp add: rec_disj_def, auto)
    apply(auto dest!:less_2_cases[unfolded numeral One_nat_def])
  done

lemma primerec_rec_less_2[intro]: "primerec rec_less (Suc (Suc 0))"
  apply(simp add: rec_less_def, auto)
    apply(auto dest!:less_2_cases[unfolded numeral One_nat_def])
  done

lemma primerec_rec_eq_2[intro]: "primerec rec_eq (Suc (Suc 0))"
  apply(simp add: rec_eq_def)
  apply(rule_tac prime_cn, auto dest!:less_2_cases[unfolded numeral One_nat_def])
       apply force+
  done

lemma primerec_rec_le_2[intro]: "primerec rec_le (Suc (Suc 0))"
  apply(simp add: rec_le_def)
  apply(rule_tac prime_cn, auto dest!:less_2_cases[unfolded numeral One_nat_def])
  done

lemma Sigma_0: " i  n. (f (xs @ [i]) = 0)  
                              Sigma f (xs @ [n]) = 0"
  apply(induct n, simp add: Sigma.simps)
  apply(simp add: Sigma_Suc_simp_rewrite)
  done

lemma Sigma_Suc[elim]: "k<Suc w. f (xs @ [k]) = Suc 0
         Sigma f (xs @ [w]) = Suc w"
  apply(induct w)
   apply(simp add: Sigma.simps, simp)
  apply(simp add: Sigma.simps)
  done

lemma Sigma_max_point: " k < ma. f (xs @ [k]) = 1;
         k  ma. f (xs @ [k]) = 0; ma  w
     Sigma f (xs @ [w]) = ma"
  apply(induct w, auto)
   apply(rule_tac Sigma_0, simp)
  apply(simp add: Sigma_Suc_simp_rewrite)
  using Sigma_Suc by fastforce

lemma Sigma_Max_lemma: 
  assumes prrf: "primerec rf (Suc (length xs))"
  shows "UF.Sigma (rec_exec (Cn (Suc (Suc (length xs))) rec_not
  [rec_all (recf.id (Suc (Suc (length xs))) (length xs))
  (Cn (Suc (Suc (Suc (length xs)))) rec_disj
  [Cn (Suc (Suc (Suc (length xs)))) rec_le
  [recf.id (Suc (Suc (Suc (length xs)))) (Suc (Suc (length xs))), 
  recf.id (Suc (Suc (Suc (length xs)))) (Suc (length xs))],
  Cn (Suc (Suc (Suc (length xs)))) rec_not
  [Cn (Suc (Suc (Suc (length xs)))) rf
  (get_fstn_args (Suc (Suc (Suc (length xs)))) (length xs) @ 
  [recf.id (Suc (Suc (Suc (length xs)))) (Suc (Suc (length xs)))])]])]))
  ((xs @ [w]) @ [w]) =
       Maxr (λargs. 0 < rec_exec rf args) xs w"
proof -
  let ?rt = "(recf.id (Suc (Suc (length xs))) ((length xs)))"
  let ?rf1 = "Cn (Suc (Suc (Suc (length xs))))
    rec_le [recf.id (Suc (Suc (Suc (length xs)))) 
    ((Suc (Suc (length xs)))), recf.id 
    (Suc (Suc (Suc (length xs)))) ((Suc (length xs)))]"
  let ?rf2 = "Cn (Suc (Suc (Suc (length xs)))) rf 
               (get_fstn_args (Suc (Suc (Suc (length xs))))
    (length xs) @ 
    [recf.id (Suc (Suc (Suc (length xs))))    
    ((Suc (Suc (length xs))))])"
  let ?rf3 = "Cn (Suc (Suc (Suc (length xs)))) rec_not [?rf2]"
  let ?rf = "Cn (Suc (Suc (Suc (length xs)))) rec_disj [?rf1, ?rf3]"
  let ?rq = "rec_all ?rt ?rf"
  let ?notrq = "Cn (Suc (Suc (length xs))) rec_not [?rq]"
  show "?thesis"
  proof(auto simp: Maxr.simps)
    assume h: "xw. rec_exec rf (xs @ [x]) = 0"
    have "primerec ?rf (Suc (length (xs @ [w, i])))  
          primerec ?rt (length (xs @ [w, i]))"
      using prrf
      apply(auto dest!:less_2_cases[unfolded numeral One_nat_def])
            apply force+
      apply(case_tac ia, auto simp: h nth_append primerec_getpren)
      done
    hence "Sigma (rec_exec ?notrq) ((xs@[w])@[w]) = 0"
      apply(rule_tac Sigma_0)
      apply(auto simp: rec_exec.simps all_lemma
          get_fstn_args_take nth_append h)
      done
    thus "UF.Sigma (rec_exec ?notrq)
      (xs @ [w, w]) = 0"
      by simp
  next
    fix x
    assume h: "x  w" "0 < rec_exec rf (xs @ [x])"
    hence " ma. Max {y. y  w  0 < rec_exec rf (xs @ [y])} = ma"
      by auto
    from this obtain ma where k1: 
      "Max {y. y  w  0 < rec_exec rf (xs @ [y])} = ma" ..
    hence k2: "ma  w  0 < rec_exec rf (xs @ [ma])"
      using h
      apply(subgoal_tac
          "Max {y. y  w  0 < rec_exec rf (xs @ [y])}   {y. y  w  0 < rec_exec rf (xs @ [y])}")
       apply(erule_tac CollectE, simp)
      apply(rule_tac Max_in, auto)
      done
    hence k3: " k < ma. (rec_exec ?notrq (xs @ [w, k]) = 1)"
      apply(auto simp: nth_append)
      apply(subgoal_tac "primerec ?rf (Suc (length (xs @ [w, k])))  
        primerec ?rt (length (xs @ [w, k]))")
       apply(auto simp: rec_exec.simps all_lemma get_fstn_args_take nth_append
          dest!:less_2_cases[unfolded numeral One_nat_def])
      using prrf
            apply force+
      done    
    have k4: " k  ma. (rec_exec ?notrq (xs @ [w, k]) = 0)"
      apply(auto)
      apply(subgoal_tac "primerec ?rf (Suc (length (xs @ [w, k])))  
        primerec ?rt (length (xs @ [w, k]))")
       apply(auto simp: rec_exec.simps all_lemma get_fstn_args_take nth_append)
       apply(subgoal_tac "x  Max {y. y  w  0 < rec_exec rf (xs @ [y])}",
          simp add: k1)
       apply(rule_tac Max_ge, auto dest!:less_2_cases[unfolded numeral One_nat_def])
      using prrf apply force+
      apply(auto simp: h nth_append)
      done 
    from k3 k4 k1 have "Sigma (rec_exec ?notrq) ((xs @ [w]) @ [w]) = ma"
      apply(rule_tac Sigma_max_point, simp, simp, simp add: k2)
      done
    from k1 and this show "Sigma (rec_exec ?notrq) (xs @ [w, w]) =
      Max {y. y  w  0 < rec_exec rf (xs @ [y])}"
      by simp
  qed  
qed

text ‹
  The correctness of rec_maxr›.
›
lemma Maxr_lemma:
  assumes h: "primerec rf (Suc (length xs))"
  shows   "rec_exec (rec_maxr rf) (xs @ [w]) = 
            Maxr (λ args. 0 < rec_exec rf args) xs w"
proof -
  from h have "arity rf = Suc (length xs)"
    by auto
  thus "?thesis"
  proof(simp add: rec_exec.simps rec_maxr.simps nth_append get_fstn_args_take)
    let ?rt = "(recf.id (Suc (Suc (length xs))) ((length xs)))"
    let ?rf1 = "Cn (Suc (Suc (Suc (length xs))))
                     rec_le [recf.id (Suc (Suc (Suc (length xs)))) 
              ((Suc (Suc (length xs)))), recf.id 
             (Suc (Suc (Suc (length xs)))) ((Suc (length xs)))]"
    let ?rf2 = "Cn (Suc (Suc (Suc (length xs)))) rf 
               (get_fstn_args (Suc (Suc (Suc (length xs))))
                (length xs) @ 
                  [recf.id (Suc (Suc (Suc (length xs))))    
                           ((Suc (Suc (length xs))))])"
    let ?rf3 = "Cn (Suc (Suc (Suc (length xs)))) rec_not [?rf2]"
    let ?rf = "Cn (Suc (Suc (Suc (length xs)))) rec_disj [?rf1, ?rf3]"
    let ?rq = "rec_all ?rt ?rf"
    let ?notrq = "Cn (Suc (Suc (length xs))) rec_not [?rq]"
    have prt: "primerec ?rt (Suc (Suc (length xs)))"
      by(auto intro: prime_id)
    have prrf: "primerec ?rf (Suc (Suc (Suc (length xs))))"
      apply(auto dest!:less_2_cases[unfolded numeral One_nat_def])
            apply force+
        apply(auto intro: prime_id)
       apply(simp add: h)
      apply(auto simp add: nth_append)
      done
    from prt and prrf have prrq: "primerec ?rq 
                                       (Suc (Suc (length xs)))"
      by(erule_tac primerec_all_iff, auto)
    hence prnotrp: "primerec ?notrq (Suc (length ((xs @ [w]))))"
      by(rule_tac prime_cn, auto)
    have g1: "rec_exec (rec_sigma ?notrq) ((xs @ [w]) @ [w]) 
      = Maxr (λargs. 0 < rec_exec rf args) xs w"
      using prnotrp
      using sigma_lemma
      apply(simp only: sigma_lemma)
      apply(rule_tac Sigma_Max_lemma)
      apply(simp add: h)
      done
    thus "rec_exec (rec_sigma ?notrq)
     (xs @ [w, w]) =
    Maxr (λargs. 0 < rec_exec rf args) xs w"
      apply(simp)
      done
  qed
qed

text quo› is the formal specification of division.
›
fun quo :: "nat list  nat"
  where
    "quo [x, y] = (let Rr = 
                         (λ zs. ((zs ! (Suc 0) * zs ! (Suc (Suc 0))
                                  zs ! 0)  zs ! Suc 0  (0::nat)))
                 in Maxr Rr [x, y] x)"

declare quo.simps[simp del]

text ‹
  The following lemmas shows more directly the menaing of quo›:
›
lemma quo_is_div: "y > 0  quo [x, y] = x div y"
proof -
  {
    fix xa ya
    assume h: "y * ya  x"  "y > 0"
    hence "(y * ya) div y  x div y"
      by(insert div_le_mono[of "y * ya" x y], simp)
    from this and h have "ya  x div y" by simp}
  thus ?thesis by(simp add: quo.simps Maxr.simps, auto,
        rule_tac Max_eqI, simp, auto)
qed

lemma quo_zero[intro]: "quo [x, 0] = 0"
  by(simp add: quo.simps Maxr.simps)

lemma quo_div: "quo [x, y] = x div y"  
  by(cases "y=0", auto elim!:quo_is_div)

text rec_noteq› is the recursive function testing whether its
  two arguments are not equal.
›
definition rec_noteq:: "recf"
  where
    "rec_noteq = Cn (Suc (Suc 0)) rec_not [Cn (Suc (Suc 0)) 
              rec_eq [id (Suc (Suc 0)) (0), id (Suc (Suc 0)) 
                                        ((Suc 0))]]"

text ‹
  The correctness of rec_noteq›.
›
lemma noteq_lemma: 
  " x y. rec_exec rec_noteq [x, y] = 
               (if x  y then 1 else 0)"
  by(simp add: rec_exec.simps rec_noteq_def)

declare noteq_lemma[simp]

text rec_quo› is the recursive function used to implement quo›
definition rec_quo :: "recf"
  where
    "rec_quo = (let rR = Cn (Suc (Suc (Suc 0))) rec_conj
              [Cn (Suc (Suc (Suc 0))) rec_le 
               [Cn (Suc (Suc (Suc 0))) rec_mult 
                  [id (Suc (Suc (Suc 0))) (Suc 0), 
                     id (Suc (Suc (Suc 0))) ((Suc (Suc 0)))],
                id (Suc (Suc (Suc 0))) (0)], 
                Cn (Suc (Suc (Suc 0))) rec_noteq 
                         [id (Suc (Suc (Suc 0))) (Suc (0)),
                Cn (Suc (Suc (Suc 0))) (constn 0) 
                              [id (Suc (Suc (Suc 0))) (0)]]] 
              in Cn (Suc (Suc 0)) (rec_maxr rR)) [id (Suc (Suc 0)) 
                           (0),id (Suc (Suc 0)) (Suc (0)), 
                                   id (Suc (Suc 0)) (0)]"

lemma primerec_rec_conj_2[intro]: "primerec rec_conj (Suc (Suc 0))"
  apply(simp add: rec_conj_def)
  apply(rule_tac prime_cn, auto dest!:less_2_cases[unfolded numeral One_nat_def])
  done

lemma primerec_rec_noteq_2[intro]: "primerec rec_noteq (Suc (Suc 0))"
  apply(simp add: rec_noteq_def)
  apply(rule_tac prime_cn, auto dest!:less_2_cases[unfolded numeral One_nat_def])
  done


lemma quo_lemma1: "rec_exec rec_quo [x, y] = quo [x, y]"
proof(simp add: rec_exec.simps rec_quo_def)
  let ?rR = "(Cn (Suc (Suc (Suc 0))) rec_conj
               [Cn (Suc (Suc (Suc 0))) rec_le
                   [Cn (Suc (Suc (Suc 0))) rec_mult 
               [recf.id (Suc (Suc (Suc 0))) (Suc (0)), 
                recf.id (Suc (Suc (Suc 0))) (Suc (Suc (0)))],
                 recf.id (Suc (Suc (Suc 0))) (0)],  
          Cn (Suc (Suc (Suc 0))) rec_noteq 
                              [recf.id (Suc (Suc (Suc 0))) 
             (Suc (0)), Cn (Suc (Suc (Suc 0))) (constn 0) 
                      [recf.id (Suc (Suc (Suc 0))) (0)]]])"
  have "rec_exec (rec_maxr ?rR) ([x, y]@ [ x]) = Maxr (λ args. 0 < rec_exec ?rR args) [x, y] x"
  proof(rule_tac Maxr_lemma, simp)
    show "primerec ?rR (Suc (Suc (Suc 0)))"
      apply(auto dest!:less_2_cases[unfolded numeral One_nat_def]) 
             apply force+
      done
  qed
  hence g1: "rec_exec (rec_maxr ?rR) ([x, y,  x]) =
             Maxr (λ args. if rec_exec ?rR args = 0 then False
                           else True) [x, y] x" 
    by simp
  have g2: "Maxr (λ args. if rec_exec ?rR args = 0 then False
                           else True) [x, y] x = quo [x, y]"
    apply(simp add: rec_exec.simps)
    apply(simp add: Maxr.simps quo.simps, auto)
    done
  from g1 and g2 show 
    "rec_exec (rec_maxr ?rR) ([x, y,  x]) = quo [x, y]"
    by simp
qed

text ‹
  The correctness of quo›.
›
lemma quo_lemma2: "rec_exec rec_quo [x, y] = x div y"
  using quo_lemma1[of x y] quo_div[of x y]
  by simp

text rec_mod› is the recursive function used to implement 
  the reminder function.
›
definition rec_mod :: "recf"
  where
    "rec_mod = Cn (Suc (Suc 0)) rec_minus [id (Suc (Suc 0)) (0), 
               Cn (Suc (Suc 0)) rec_mult [rec_quo, id (Suc (Suc 0))
                                                     (Suc (0))]]"

text ‹
  The correctness of rec_mod›:
›
lemma mod_lemma: " x y. rec_exec rec_mod [x, y] = (x mod y)"
  by(simp add: rec_exec.simps rec_mod_def quo_lemma2 minus_div_mult_eq_mod)

text‹lemmas for embranch function›
type_synonym ftype = "nat list  nat"
type_synonym rtype = "nat list  bool"

text ‹
  The specifation of the mutli-way branching statement on
  page 79 of Boolos's book.
›
fun Embranch :: "(ftype * rtype) list  nat list  nat"
  where
    "Embranch [] xs = 0" |
    "Embranch (gc # gcs) xs = (
                   let (g, c) = gc in 
                   if c xs then g xs else Embranch gcs xs)"

fun rec_embranch' :: "(recf * recf) list  nat  recf"
  where
    "rec_embranch' [] vl = Cn vl z [id vl (vl - 1)]" |
    "rec_embranch' ((rg, rc) # rgcs) vl = Cn vl rec_add
                   [Cn vl rec_mult [rg, rc], rec_embranch' rgcs vl]"

text rec_embrach› is the recursive function used to implement
  Embranch›.
›
fun rec_embranch :: "(recf * recf) list  recf"
  where
    "rec_embranch ((rg, rc) # rgcs) = 
         (let vl = arity rg in 
          rec_embranch' ((rg, rc) # rgcs) vl)"

declare Embranch.simps[simp del] rec_embranch.simps[simp del]

lemma embranch_all0: 
  " j < length rcs. rec_exec (rcs ! j) xs = 0;
    length rgs = length rcs;  
  rcs  []; 
  list_all (λ rf. primerec rf (length xs)) (rgs @ rcs)   
  rec_exec (rec_embranch (zip rgs rcs)) xs = 0"
proof(induct rcs arbitrary: rgs)
  case (Cons a rcs)
  then show ?case proof(cases rgs, simp)  fix a rcs rgs aa list
    assume ind: 
      "rgs. j<length rcs. rec_exec (rcs ! j) xs = 0; 
             length rgs = length rcs; rcs  []; 
            list_all (λrf. primerec rf (length xs)) (rgs @ rcs)  
                      rec_exec (rec_embranch (zip rgs rcs)) xs = 0"
      and h:  "j<length (a # rcs). rec_exec ((a # rcs) ! j) xs = 0"
      "length rgs = length (a # rcs)" 
      "a # rcs  []" 
      "list_all (λrf. primerec rf (length xs)) (rgs @ a # rcs)"
      "rgs = aa # list"
    have g: "rcs  []  rec_exec (rec_embranch (zip list rcs)) xs = 0"
      using h by(rule_tac ind, auto)
    show "rec_exec (rec_embranch (zip rgs (a # rcs))) xs = 0"
    proof(cases "rcs = []", simp)
      show "rec_exec (rec_embranch (zip rgs [a])) xs = 0"
        using h by (auto simp add: rec_embranch.simps rec_exec.simps)
    next
      assume "rcs  []"
      hence "rec_exec (rec_embranch (zip list rcs)) xs = 0"
        using g by simp
      thus "rec_exec (rec_embranch (zip rgs (a # rcs))) xs = 0"
        using h
        by(cases rcs;cases list, auto simp add: rec_embranch.simps rec_exec.simps)
    qed
  qed
qed simp


lemma embranch_exec_0: "rec_exec aa xs = 0; zip rgs list  []; 
       list_all (λ rf. primerec rf (length xs)) ([a, aa] @ rgs @ list)
        rec_exec (rec_embranch ((a, aa) # zip rgs list)) xs
         = rec_exec (rec_embranch (zip rgs list)) xs"
  apply(auto simp add: rec_exec.simps rec_embranch.simps)
  apply(cases "zip rgs list", force)
  apply(cases "hd (zip rgs list)", simp add: rec_embranch.simps rec_exec.simps)
  apply(subgoal_tac "arity a = length xs")
   apply(cases rgs;cases list;force)
  by force

lemma zip_null_iff: "length xs = k; length ys = k; zip xs ys = []  xs = []  ys = []"
  apply(cases xs, simp, simp)
  apply(cases ys, simp, simp)
  done

lemma zip_null_gr: "length xs = k; length ys = k; zip xs ys  []  0 < k"
  apply(cases xs, simp, simp)
  done

lemma Embranch_0:  
  "length rgs = k; length rcs = k; k > 0; 
   j < k. rec_exec (rcs ! j) xs = 0 
  Embranch (zip (map rec_exec rgs) (map (λr args. 0 < rec_exec r args) rcs)) xs = 0"
proof(induct rgs arbitrary: rcs k)
  case (Cons a rgs rcs k)
  then show ?case
    apply(cases rcs, simp, cases "rgs = []")
     apply(simp add: Embranch.simps)
     apply(erule_tac x = 0 in allE)
     apply (auto simp add: Embranch.simps intro!: Cons(1)).
qed simp

text ‹
  The correctness of rec_embranch›.
›
lemma embranch_lemma:
  assumes branch_num:
    "length rgs = n" "length rcs = n" "n > 0"
    and partition: 
    "( i < n. (rec_exec (rcs ! i) xs = 1  ( j < n. j  i  
                                      rec_exec (rcs ! j) xs = 0)))"
    and prime_all: "list_all (λ rf. primerec rf (length xs)) (rgs @ rcs)"
  shows "rec_exec (rec_embranch (zip rgs rcs)) xs =
                  Embranch (zip (map rec_exec rgs) 
                     (map (λ r args. 0 < rec_exec r args) rcs)) xs"
  using branch_num partition prime_all
proof(induct rgs arbitrary: rcs n, simp)
  fix a rgs rcs n
  assume ind: 
    "rcs n. length rgs = n; length rcs = n; 0 < n;
    i<n. rec_exec (rcs ! i) xs = 1  (j<n. j  i  rec_exec (rcs ! j) xs = 0);
    list_all (λrf. primerec rf (length xs)) (rgs @ rcs)
     rec_exec (rec_embranch (zip rgs rcs)) xs =
    Embranch (zip (map rec_exec rgs) (map (λr args. 0 < rec_exec r args) rcs)) xs"
    and h: "length (a # rgs) = n" "length (rcs::recf list) = n" "0 < n"
    " i<n. rec_exec (rcs ! i) xs = 1  
         (j<n. j  i  rec_exec (rcs ! j) xs = 0)" 
    "list_all (λrf. primerec rf (length xs)) ((a # rgs) @ rcs)"
  from h show "rec_exec (rec_embranch (zip (a # rgs) rcs)) xs =
    Embranch (zip (map rec_exec (a # rgs)) (map (λr args. 
                0 < rec_exec r args) rcs)) xs"
    apply(cases rcs, simp, simp)
    apply(cases "rec_exec (hd rcs) xs = 0")
     apply(case_tac [!] "zip rgs (tl rcs) = []", simp)
       apply(subgoal_tac "rgs = []  (tl rcs) = []", simp add: Embranch.simps rec_exec.simps rec_embranch.simps)
       apply(rule_tac  zip_null_iff, simp, simp, simp)
  proof -
    fix aa list
    assume "rcs = aa # list"
    assume g:
      "Suc (length rgs) = n" "Suc (length list) = n" 
      "i<n. rec_exec ((aa # list) ! i) xs = Suc 0  
          (j<n. j  i  rec_exec ((aa # list) ! j) xs = 0)"
      "primerec a (length xs)  
      list_all (λrf. primerec rf (length xs)) rgs 
      primerec aa (length xs)  
      list_all (λrf. primerec rf (length xs)) list"
      "rec_exec (hd rcs) xs = 0" "rcs = aa # list" "zip rgs (tl rcs)  []"
    hence "rec_exec aa xs = 0" "zip rgs list  []" by auto
    note g = g(1,2,3,4,6) this
    have "rec_exec (rec_embranch ((a, aa) # zip rgs list)) xs
        = rec_exec (rec_embranch (zip rgs list)) xs"
      apply(rule embranch_exec_0, simp_all add: g)
      done
    from g and this show "rec_exec (rec_embranch ((a, aa) # zip rgs list)) xs =
         Embranch ((rec_exec a, λargs. 0 < rec_exec aa args) # 
           zip (map rec_exec rgs) (map (λr args. 0 < rec_exec r args) list)) xs"
      apply(simp add: Embranch.simps)
      apply(rule_tac n = "n - Suc 0" in ind)
          apply(cases n;force)
         apply(cases n;force)
        apply(cases n;force simp add: zip_null_gr)
       apply(auto)
      apply(rename_tac i)
      apply(case_tac i, force, simp)
      apply(rule_tac x = "i - 1" in exI, simp)
      by auto
  next
    fix aa list
    assume g: "Suc (length rgs) = n" "Suc (length list) = n"
      "i<n. rec_exec ((aa # list) ! i) xs = Suc 0  
      (j<n. j  i  rec_exec ((aa # list) ! j) xs = 0)"
      "primerec a (length xs)  list_all (λrf. primerec rf (length xs)) rgs 
      primerec aa (length xs)  list_all (λrf. primerec rf (length xs)) list"
      "rcs = aa # list" "rec_exec (hd rcs) xs  0" "zip rgs (tl rcs) = []"
    thus "rec_exec (rec_embranch ((a, aa) # zip rgs list)) xs = 
        Embranch ((rec_exec a, λargs. 0 < rec_exec aa args) # 
       zip (map rec_exec rgs) (map (λr args. 0 < rec_exec r args) list)) xs"
      apply(subgoal_tac "rgs = []  list = []", simp)
       prefer 2
       apply(rule_tac zip_null_iff, simp, simp, simp)
      apply(simp add: rec_exec.simps rec_embranch.simps Embranch.simps, auto)
      done
  next
    fix aa list
    assume g: "Suc (length rgs) = n" "Suc (length list) = n"
      "i<n. rec_exec ((aa # list) ! i) xs = Suc 0   
           (j<n. j  i  rec_exec ((aa # list) ! j) xs = 0)"
      "primerec a (length xs)  list_all (λrf. primerec rf (length xs)) rgs
       primerec aa (length xs)  list_all (λrf. primerec rf (length xs)) list"
      "rcs = aa # list" "rec_exec (hd rcs) xs  0" "zip rgs (tl rcs)  []"
    have "rec_exec aa xs =  Suc 0"
      using g
      apply(cases "rec_exec aa xs", simp, auto)
      done      
    moreover have "rec_exec (rec_embranch' (zip rgs list) (length xs)) xs = 0"
    proof -
      have "rec_embranch' (zip rgs list) (length xs) = rec_embranch (zip rgs list)"
        using g
        apply(cases "zip rgs list", force)
        apply(cases "hd (zip rgs list)")
        apply(simp add: rec_embranch.simps)
        apply(cases rgs, simp, simp, cases list, simp, auto)
        done
      moreover have "rec_exec (rec_embranch (zip rgs list)) xs = 0"
      proof(rule embranch_all0)
        show " j<length list. rec_exec (list ! j) xs = 0"
          using g
          apply(auto)
          apply(rename_tac i j)
          apply(case_tac i, simp)
           apply(erule_tac x = "Suc j" in allE, simp)
          apply(simp)
          apply(erule_tac x = 0 in allE, simp)
          done
      next
        show "length rgs = length list"
          using g by(cases n;force)
      next
        show "list  []"
          using g by(cases list; force)
      next
        show "list_all (λrf. primerec rf (length xs)) (rgs @ list)"
          using g by auto
      qed
      ultimately show "rec_exec (rec_embranch' (zip rgs list) (length xs)) xs = 0"
        by simp
    qed
    moreover have 
      "Embranch (zip (map rec_exec rgs) 
          (map (λr args. 0 < rec_exec r args) list)) xs = 0"
      using g
      apply(rule_tac k = "length rgs" in Embranch_0)
         apply(simp, cases n, simp, simp)
       apply(cases rgs, simp, simp)
      apply(auto)
      apply(rename_tac i j)
      apply(case_tac i, simp)
       apply(erule_tac x = "Suc j" in allE, simp)
      apply(simp)
      apply(rule_tac x = 0 in allE, auto)
      done
    moreover have "arity a = length xs"
      using g
      apply(auto)
      done
    ultimately show "rec_exec (rec_embranch ((a, aa) # zip rgs list)) xs = 
      Embranch ((rec_exec a, λargs. 0 < rec_exec aa args) #
           zip (map rec_exec rgs) (map (λr args. 0 < rec_exec r args) list)) xs"
      apply(simp add: rec_exec.simps rec_embranch.simps Embranch.simps)
      done
  qed
qed

textprime n› means n› is a prime number.
›
fun Prime :: "nat  bool"
  where
    "Prime x = (1 < x  ( u < x. ( v < x. u * v  x)))"

declare Prime.simps [simp del]

lemma primerec_all1: 
  "primerec (rec_all rt rf) n  primerec rt n"
  by (simp add: primerec_all)

lemma primerec_all2: "primerec (rec_all rt rf) n  
  primerec rf (Suc n)"
  by(insert primerec_all[of rt rf n], simp)

text rec_prime› is the recursive function used to implement
  Prime›.
›
definition rec_prime :: "recf"
  where
    "rec_prime = Cn (Suc 0) rec_conj 
  [Cn (Suc 0) rec_less [constn 1, id (Suc 0) (0)],
        rec_all (Cn 1 rec_minus [id 1 0, constn 1]) 
       (rec_all (Cn 2 rec_minus [id 2 0, Cn 2 (constn 1) 
  [id 2 0]]) (Cn 3 rec_noteq 
       [Cn 3 rec_mult [id 3 1, id 3 2], id 3 0]))]"

declare numeral_2_eq_2[simp del] numeral_3_eq_3[simp del]

lemma exec_tmp: 
  "rec_exec (rec_all (Cn 2 rec_minus [recf.id 2 0, Cn 2 (constn (Suc 0)) [recf.id 2 0]]) 
  (Cn 3 rec_noteq [Cn 3 rec_mult [recf.id 3 (Suc 0), recf.id 3 2], recf.id 3 0]))  [x, k] = 
  ((if (wrec_exec (Cn 2 rec_minus [recf.id 2 0, Cn 2 (constn (Suc 0)) [recf.id 2 0]]) ([x, k]). 
  0 < rec_exec (Cn 3 rec_noteq [Cn 3 rec_mult [recf.id 3 (Suc 0), recf.id 3 2], recf.id 3 0])
  ([x, k] @ [w])) then 1 else 0))"
  apply(rule_tac all_lemma)
   apply(auto simp:numeral)
   apply (metis (no_types, lifting) Suc_mono length_Cons less_2_cases list.size(3) nth_Cons_0
      nth_Cons_Suc numeral_2_eq_2 prime_cn prime_id primerec_rec_mult_2 zero_less_Suc)
  by (metis (no_types, lifting) One_nat_def length_Cons less_2_cases nth_Cons_0 nth_Cons_Suc 
      prime_cn_reverse primerec_rec_eq_2 rec_eq_def zero_less_Suc)

text ‹
  The correctness of Prime›.
›
lemma prime_lemma: "rec_exec rec_prime [x] = (if Prime x then 1 else 0)"
proof(simp add: rec_exec.simps rec_prime_def)
  let ?rt1 = "(Cn 2 rec_minus [recf.id 2 0, 
    Cn 2 (constn (Suc 0)) [recf.id 2 0]])"
  let ?rf1 = "(Cn 3 rec_noteq [Cn 3 rec_mult 
    [recf.id 3 (Suc 0), recf.id 3 2], recf.id 3 (0)])"
  let ?rt2 = "(Cn (Suc 0) rec_minus 
    [recf.id (Suc 0) 0, constn (Suc 0)])"
  let ?rf2 = "rec_all ?rt1 ?rf1"
  have h1: "rec_exec (rec_all ?rt2 ?rf2) ([x]) = 
        (if (krec_exec ?rt2 ([x]). 0 < rec_exec ?rf2 ([x] @ [k])) then 1 else 0)"
  proof(rule_tac all_lemma, simp_all)
    show "primerec ?rf2 (Suc (Suc 0))"
      apply(rule_tac primerec_all_iff)
        apply(auto simp: numeral)
       apply (metis (no_types, lifting) One_nat_def length_Cons less_2_cases nth_Cons_0 nth_Cons_Suc
          prime_cn_reverse primerec_rec_eq_2 rec_eq_def zero_less_Suc)
      by (metis (no_types, lifting) Suc_mono length_Cons less_2_cases list.size(3) nth_Cons_0 
          nth_Cons_Suc numeral_2_eq_2 prime_cn prime_id primerec_rec_mult_2 zero_less_Suc)
  next
    show "primerec (Cn (Suc 0) rec_minus
             [recf.id (Suc 0) 0, constn (Suc 0)]) (Suc 0)"
      using less_2_cases numeral by fastforce
  qed
  from h1 show 
    "(Suc 0 < x   (rec_exec (rec_all ?rt2 ?rf2) [x] = 0  
    ¬ Prime x) 
     (0 < rec_exec (rec_all ?rt2 ?rf2) [x]  Prime x)) 
    (¬ Suc 0 < x  ¬ Prime x  (rec_exec (rec_all ?rt2 ?rf2) [x] = 0
     ¬ Prime x))"
    apply(auto simp:rec_exec.simps)
       apply(simp add: exec_tmp rec_exec.simps)
  proof -
    assume *:"kx - Suc 0. (0::nat) < (if wx - Suc 0. 
           0 < (if k * w  x then 1 else (0 :: nat)) then 1 else 0)" "Suc 0 < x"
    thus "Prime x"
      apply(simp add: rec_exec.simps split: if_splits)
      apply(simp add: Prime.simps, auto)
      apply(rename_tac u v)
      apply(erule_tac x = u in allE, auto)
       apply(case_tac u, simp)
       apply(case_tac "u - 1", simp, simp)
      apply(case_tac v, simp)
      apply(case_tac "v - 1", simp, simp)
      done
  next
    assume "¬ Suc 0 < x" "Prime x"
    thus "False"
      apply(simp add: Prime.simps)
      done
  next
    fix k
    assume "rec_exec (rec_all ?rt1 ?rf1)
      [x, k] = 0" "k  x - Suc 0" "Prime x"
    thus "False"
      apply(simp add: exec_tmp rec_exec.simps Prime.simps split: if_splits)
      done
  next
    fix k
    assume "rec_exec (rec_all ?rt1 ?rf1)
      [x, k] = 0" "k  x - Suc 0" "Prime x"
    thus "False"
      apply(simp add: exec_tmp rec_exec.simps Prime.simps split: if_splits)
      done
  qed
qed

definition rec_dummyfac :: "recf"
  where
    "rec_dummyfac = Pr 1 (constn 1) 
  (Cn 3 rec_mult [id 3 2, Cn 3 s [id 3 1]])"

text ‹
  The recursive function used to implment factorization.
›
definition rec_fac :: "recf"
  where
    "rec_fac = Cn 1 rec_dummyfac [id 1 0, id 1 0]"

text ‹
  Formal specification of factorization.
›
fun fac :: "nat  nat"  ("_!" [100] 99)
  where
    "fac 0 = 1" |
    "fac (Suc x) = (Suc x) * fac x"

lemma fac_dummy: "rec_exec rec_dummyfac [x, y] = y !"
  apply(induct y)
   apply(auto simp: rec_dummyfac_def rec_exec.simps)
  done

text ‹
  The correctness of rec_fac›.
›
lemma fac_lemma: "rec_exec rec_fac [x] =  x!"
  apply(simp add: rec_fac_def rec_exec.simps fac_dummy)
  done

declare fac.simps[simp del]

text Np x› returns the first prime number after x›.
›
fun Np ::"nat  nat"
  where
    "Np x = Min {y. y  Suc (x!)  x < y  Prime y}"

declare Np.simps[simp del] rec_Minr.simps[simp del]

text rec_np› is the recursive function used to implement
  Np›.
›
definition rec_np :: "recf"
  where
    "rec_np = (let Rr = Cn 2 rec_conj [Cn 2 rec_less [id 2 0, id 2 1], 
  Cn 2 rec_prime [id 2 1]]
             in Cn 1 (rec_Minr Rr) [id 1 0, Cn 1 s [rec_fac]])"

lemma n_le_fact[simp]: "n < Suc (n!)"
proof(induct n)
  case (Suc n)
  then show ?case  apply(simp add: fac.simps)
    apply(cases n, auto simp: fac.simps)
    done
qed simp

lemma divsor_ex: 
  "¬ Prime x; x > Suc 0  ( u > Suc 0. ( v > Suc 0. u * v = x))"
  by(auto simp: Prime.simps)

lemma divsor_prime_ex: "¬ Prime x; x > Suc 0  
   p. Prime p  p dvd x"
  apply(induct x rule: wf_induct[where r = "measure (λ y. y)"], simp)
  apply(drule_tac divsor_ex, simp, auto)
  apply(rename_tac u v)
  apply(erule_tac x = u in allE, simp)
  apply(case_tac "Prime u", simp)
   apply(rule_tac x = u in exI, simp, auto)
  done

lemma fact_pos[intro]: "0 < n!"
  apply(induct n)
   apply(auto simp: fac.simps)
  done

lemma fac_Suc: "Suc n! =  (Suc n) * (n!)" by(simp add: fac.simps)

lemma fac_dvd: "0 < q; q  n  q dvd n!"
proof(induct n)
  case (Suc n)
  then show ?case 
    apply(cases "q  n", simp add: fac_Suc)
    apply(subgoal_tac "q = Suc n", simp only: fac_Suc)
     apply(rule_tac dvd_mult2, simp, simp)
    done
qed simp

lemma fac_dvd2: "Suc 0 < q; q dvd n!; q  n  ¬ q dvd Suc (n!)"
proof(auto simp: dvd_def)
  fix k ka
  assume h1: "Suc 0 < q" "q  n"
    and h2: "Suc (q * k) = q * ka"
  have "k < ka"
  proof - 
    have "q * k < q * ka" 
      using h2 by arith
    thus "k < ka"
      using h1
      by(auto)
  qed
  hence "d. d > 0   ka = d + k"  
    by(rule_tac x = "ka - k" in exI, simp)
  from this obtain d where "d > 0  ka = d + k" ..
  from h2 and this and h1 show "False"
    by(simp add: add_mult_distrib2)
qed

lemma prime_ex: " p. n < p  p  Suc (n!)  Prime p"
proof(cases "Prime (n! + 1)")
  case True thus "?thesis" 
    by(rule_tac x = "Suc (n!)" in exI, simp)
next
  assume h: "¬ Prime (n! + 1)"  
  hence " p. Prime p  p dvd (n! + 1)"
    by(erule_tac divsor_prime_ex, auto)
  from this obtain q where k: "Prime q  q dvd (n! + 1)" ..
  thus "?thesis"
  proof(cases "q > n")
    case True thus "?thesis"
      using k by(auto intro:dvd_imp_le)
  next
    case False thus "?thesis"
    proof -
      assume g: "¬ n < q"
      have j: "q > Suc 0"
        using k by(cases q, auto simp: Prime.simps)
      hence "q dvd n!"
        using g 
        apply(rule_tac fac_dvd, auto)
        done
      hence "¬ q dvd Suc (n!)"
        using g j
        by(rule_tac fac_dvd2, auto)
      thus "?thesis"
        using k by simp
    qed
  qed
qed

lemma Suc_Suc_induct[elim!]: "i < Suc (Suc 0); 
  primerec (ys ! 0) n; primerec (ys ! 1) n  primerec (ys ! i) n"
  by(cases i, auto)

lemma primerec_rec_prime_1[intro]: "primerec rec_prime (Suc 0)"
  apply(auto simp: rec_prime_def, auto)
  apply(rule_tac primerec_all_iff, auto, auto)
  apply(rule_tac primerec_all_iff, auto, auto simp:  
      numeral_2_eq_2 numeral_3_eq_3)
  done

text ‹
  The correctness of rec_np›.
›
lemma np_lemma: "rec_exec rec_np [x] = Np x"
proof(auto simp: rec_np_def rec_exec.simps Let_def fac_lemma)
  let ?rr = "(Cn 2 rec_conj [Cn 2 rec_less [recf.id 2 0,
    recf.id 2 (Suc 0)], Cn 2 rec_prime [recf.id 2 (Suc 0)]])"
  let ?R = "λ zs. zs ! 0 < zs ! 1  Prime (zs ! 1)"
  have g1: "rec_exec (rec_Minr ?rr) ([x] @ [Suc (x!)]) = 
    Minr (λ args. 0 < rec_exec ?rr args) [x] (Suc (x!))"
    by(rule_tac Minr_lemma, auto simp: rec_exec.simps
        prime_lemma, auto simp:  numeral_2_eq_2 numeral_3_eq_3)
  have g2: "Minr (λ args. 0 < rec_exec ?rr args) [x] (Suc (x!)) = Np x"
    using prime_ex[of x]
    apply(auto simp: Minr.simps Np.simps rec_exec.simps prime_lemma)
    apply(subgoal_tac
        "{uu. (Prime uu  (x < uu  uu  Suc (x!))  x < uu)  Prime uu}
    = {y. y  Suc (x!)  x < y  Prime y}", auto)
    done
  from g1 and g2 show "rec_exec (rec_Minr ?rr) ([x, Suc (x!)]) = Np x"
    by simp
qed

text rec_power› is the recursive function used to implement
  power function.
›
definition rec_power :: "recf"
  where
    "rec_power = Pr 1 (constn 1) (Cn 3 rec_mult [id 3 0, id 3 2])"

text ‹
  The correctness of rec_power›.
›
lemma power_lemma: "rec_exec rec_power [x, y] = x^y"
  by(induct y, auto simp: rec_exec.simps rec_power_def)

textPi k› returns the k›-th prime number.
›
fun Pi :: "nat  nat"
  where
    "Pi 0 = 2" |
    "Pi (Suc x) = Np (Pi x)"

definition rec_dummy_pi :: "recf"
  where
    "rec_dummy_pi = Pr 1 (constn 2) (Cn 3 rec_np [id 3 2])"

text rec_pi› is the recursive function used to implement
  Pi›.
›
definition rec_pi :: "recf"
  where
    "rec_pi = Cn 1 rec_dummy_pi [id 1 0, id 1 0]"

lemma pi_dummy_lemma: "rec_exec rec_dummy_pi [x, y] = Pi y"
  apply(induct y)
  by(auto simp: rec_exec.simps rec_dummy_pi_def Pi.simps np_lemma)

text ‹
  The correctness of rec_pi›.
›
lemma pi_lemma: "rec_exec rec_pi [x] = Pi x"
  apply(simp add: rec_pi_def rec_exec.simps pi_dummy_lemma)
  done

fun loR :: "nat list  bool"
  where
    "loR [x, y, u] = (x mod (y^u) = 0)"

declare loR.simps[simp del]

text Lo› specifies the lo› function given on page 79 of 
  Boolos's book. It is one of the two notions of integeral logarithmetic
  operation on that page. The other is lg›.
›
fun lo :: " nat  nat  nat"
  where 
    "lo x y  = (if x > 1  y > 1  {u. loR [x, y, u]}  {} then Max {u. loR [x, y, u]}
                                                         else 0)"

declare lo.simps[simp del]

lemma primerec_sigma[intro!]:  
  "n > Suc 0; primerec rf n  
  primerec (rec_sigma rf) n"
  apply(simp add: rec_sigma.simps)
  apply(auto, auto simp: nth_append)
  done

lemma primerec_rec_maxr[intro!]:  "primerec rf n; n > 0  primerec (rec_maxr rf) n"
  apply(simp add: rec_maxr.simps)
  apply(rule_tac prime_cn, auto)
   apply(rule_tac primerec_all_iff, auto, auto simp: nth_append)
  done

lemma Suc_Suc_Suc_induct[elim!]: 
  "i < Suc (Suc (Suc (0::nat))); primerec (ys ! 0) n;
  primerec (ys ! 1) n;  
  primerec (ys ! 2) n  primerec (ys ! i) n"
  apply(cases i, auto)
  apply(cases "i-1", simp, simp add: numeral_2_eq_2)
  done

lemma primerec_2[intro]:
  "primerec rec_quo (Suc (Suc 0))" "primerec rec_mod (Suc (Suc 0))"
  "primerec rec_power (Suc (Suc 0))"
  by(force simp: prime_cn prime_id rec_mod_def rec_quo_def rec_power_def prime_pr numeral)+

text rec_lo› is the recursive function used to implement Lo›.
›
definition rec_lo :: "recf"
  where
    "rec_lo = (let rR = Cn 3 rec_eq [Cn 3 rec_mod [id 3 0, 
               Cn 3 rec_power [id 3 1, id 3 2]], 
                     Cn 3 (constn 0) [id 3 1]] in
             let rb =  Cn 2 (rec_maxr rR) [id 2 0, id 2 1, id 2 0] in 
             let rcond = Cn 2 rec_conj [Cn 2 rec_less [Cn 2 (constn 1)
                                             [id 2 0], id 2 0], 
                                        Cn 2 rec_less [Cn 2 (constn 1)
                                                [id 2 0], id 2 1]] in 
             let rcond2 = Cn 2 rec_minus 
                              [Cn 2 (constn 1) [id 2 0], rcond] 
             in Cn 2 rec_add [Cn 2 rec_mult [rb, rcond], 
                  Cn 2 rec_mult [Cn 2 (constn 0) [id 2 0], rcond2]])"

lemma rec_lo_Maxr_lor:
  "Suc 0 < x; Suc 0 < y   
        rec_exec rec_lo [x, y] = Maxr loR [x, y] x"
proof(auto simp: rec_exec.simps rec_lo_def Let_def 
    numeral_2_eq_2 numeral_3_eq_3)
  let ?rR = "(Cn (Suc (Suc (Suc 0))) rec_eq
     [Cn (Suc (Suc (Suc 0))) rec_mod [recf.id (Suc (Suc (Suc 0))) 0,
     Cn (Suc (Suc (Suc 0))) rec_power [recf.id (Suc (Suc (Suc 0)))
     (Suc 0), recf.id (Suc (Suc (Suc 0))) (Suc (Suc 0))]],
     Cn (Suc (Suc (Suc 0))) (constn 0) [recf.id (Suc (Suc (Suc 0))) (Suc 0)]])"
  have h: "rec_exec (rec_maxr ?rR) ([x, y] @ [x]) =
    Maxr (λ args. 0 < rec_exec ?rR args) [x, y] x"
    by(rule_tac Maxr_lemma, auto simp: rec_exec.simps
        mod_lemma power_lemma, auto simp: numeral_2_eq_2 numeral_3_eq_3)
  have "Maxr loR [x, y] x =  Maxr (λ args. 0 < rec_exec ?rR args) [x, y] x"
    apply(simp add: rec_exec.simps mod_lemma power_lemma)
    apply(simp add: Maxr.simps loR.simps)
    done
  from h and this show "rec_exec (rec_maxr ?rR) [x, y, x] = 
    Maxr loR [x, y] x"
    apply(simp)
    done
qed

lemma x_less_exp: "y > Suc 0  x < y^x"
proof(induct x)
  case (Suc x)
  then show ?case  
    apply(cases x, simp, auto)
    apply(rule_tac y = "y* y^(x-1)" in le_less_trans, auto)
    done
qed simp


lemma uplimit_loR:
  assumes "Suc 0 < x" "Suc 0 < y" "loR [x, y, xa]"
  shows "xa  x"
proof -
  have "Suc 0 < x  Suc 0 < y  y ^ xa dvd x  xa  x" 
    by (meson Suc_lessD le_less_trans nat_dvd_not_less nat_le_linear x_less_exp)
  thus ?thesis using assms by(auto simp: loR.simps)
qed

lemma loR_set_strengthen[simp]: "xa  x; loR [x, y, xa]; Suc 0 < x; Suc 0 < y 
  {u. loR [x, y, u]} = {ya. ya  x  loR [x, y, ya]}"
  apply(rule_tac Collect_cong, auto)
  apply(erule_tac uplimit_loR, simp, simp)
  done

lemma Maxr_lo: "Suc 0 < x; Suc 0 < y 
  Maxr loR [x, y] x = lo x y" 
  apply(simp add: Maxr.simps lo.simps, auto simp: uplimit_loR)
  by (meson uplimit_loR)+

lemma lo_lemma': "Suc 0 < x; Suc 0 < y  
  rec_exec rec_lo [x, y] = lo x y"
  by(simp add: Maxr_lo  rec_lo_Maxr_lor)

lemma lo_lemma'': "¬ Suc 0 < x  rec_exec rec_lo [x, y] = lo x y"
  apply(cases x, auto simp: rec_exec.simps rec_lo_def 
      Let_def lo.simps)
  done

lemma lo_lemma''': "¬ Suc 0 < y  rec_exec rec_lo [x, y] = lo x y"
  apply(cases y, auto simp: rec_exec.simps rec_lo_def 
      Let_def lo.simps)
  done

text ‹
  The correctness of rec_lo›:
›
lemma lo_lemma: "rec_exec rec_lo [x, y] = lo x y" 
  apply(cases "Suc 0 < x  Suc 0 < y")
   apply(auto simp: lo_lemma' lo_lemma'' lo_lemma''')
  done

fun lgR :: "nat list  bool"
  where
    "lgR [x, y, u] = (y^u  x)"

text lg› specifies the lg› function given on page 79 of 
  Boolos's book. It is one of the two notions of integeral logarithmetic
  operation on that page. The other is lo›.
›
fun lg :: "nat  nat  nat"
  where
    "lg x y = (if x > 1  y > 1  {u. lgR [x, y, u]}  {} then 
                 Max {u. lgR [x, y, u]}
              else 0)"

declare lg.simps[simp del] lgR.simps[simp del]

text rec_lg› is the recursive function used to implement lg›.
›
definition rec_lg :: "recf"
  where
    "rec_lg = (let rec_lgR = Cn 3 rec_le
  [Cn 3 rec_power [id 3 1, id 3 2], id 3 0] in
  let conR1 = Cn 2 rec_conj [Cn 2 rec_less 
                     [Cn 2 (constn 1) [id 2 0], id 2 0], 
                            Cn 2 rec_less [Cn 2 (constn 1) 
                                 [id 2 0], id 2 1]] in 
  let conR2 = Cn 2 rec_not [conR1] in 
        Cn 2 rec_add [Cn 2 rec_mult 
              [conR1, Cn 2 (rec_maxr rec_lgR)
                       [id 2 0, id 2 1, id 2 0]], 
                       Cn 2 rec_mult [conR2, Cn 2 (constn 0) 
                                [id 2 0]]])"

lemma lg_maxr: "Suc 0 < x; Suc 0 < y  
                      rec_exec rec_lg [x, y] = Maxr lgR [x, y] x"
proof(simp add: rec_exec.simps rec_lg_def Let_def)
  assume h: "Suc 0 < x" "Suc 0 < y"
  let ?rR = "(Cn 3 rec_le [Cn 3 rec_power
               [recf.id 3 (Suc 0), recf.id 3 2], recf.id 3 0])"
  have "rec_exec (rec_maxr ?rR) ([x, y] @ [x])
              = Maxr ((λ args. 0 < rec_exec ?rR args)) [x, y] x" 
  proof(rule Maxr_lemma)
    show "primerec (Cn 3 rec_le [Cn 3 rec_power 
              [recf.id 3 (Suc 0), recf.id 3 2], recf.id 3 0]) (Suc (length [x, y]))"
      apply(auto simp: numeral_3_eq_3)+
      done
  qed
  moreover have "Maxr lgR [x, y] x = Maxr ((λ args. 0 < rec_exec ?rR args)) [x, y] x"
    apply(simp add: rec_exec.simps power_lemma)
    apply(simp add: Maxr.simps lgR.simps)
    done 
  ultimately show "rec_exec (rec_maxr ?rR) [x, y, x] = Maxr lgR [x, y] x"
    by simp
qed

lemma lgR_ok: "Suc 0 < y; lgR [x, y, xa]  xa  x"
  apply(auto simp add: lgR.simps)
  apply(subgoal_tac "y^xa > xa", simp)
  apply(erule x_less_exp)
  done

lemma lgR_set_strengthen[simp]: "Suc 0 < x; Suc 0 < y; lgR [x, y, xa] 
           {u. lgR [x, y, u]} =  {ya. ya  x  lgR [x, y, ya]}"
  apply(rule_tac Collect_cong, auto simp:lgR_ok)
  done

lemma maxr_lg: "Suc 0 < x; Suc 0 < y  Maxr lgR [x, y] x = lg x y"
  apply(auto simp add: lg.simps Maxr.simps)
  using lgR_ok by blast

lemma lg_lemma': "Suc 0 < x; Suc 0 < y  rec_exec rec_lg [x, y] = lg x y"
  apply(simp add: maxr_lg lg_maxr)
  done

lemma lg_lemma'': "¬ Suc 0 < x  rec_exec rec_lg [x, y] = lg x y"
  apply(simp add: rec_exec.simps rec_lg_def Let_def lg.simps)
  done

lemma lg_lemma''': "¬ Suc 0 < y  rec_exec rec_lg [x, y] = lg x y"
  apply(simp add: rec_exec.simps rec_lg_def Let_def lg.simps)
  done

text ‹
  The correctness of rec_lg›.
›
lemma lg_lemma: "rec_exec rec_lg [x, y] = lg x y"
  apply(cases "Suc 0 < x  Suc 0 < y", auto simp: 
      lg_lemma' lg_lemma'' lg_lemma''')
  done

text Entry sr i› returns the i›-th entry of a list of natural 
  numbers encoded by number sr› using Godel's coding.
›
fun Entry :: "nat  nat  nat"
  where
    "Entry sr i = lo sr (Pi (Suc i))"

text rec_entry› is the recursive function used to implement
  Entry›.
›
definition rec_entry:: "recf"
  where
    "rec_entry = Cn 2 rec_lo [id 2 0, Cn 2 rec_pi [Cn 2 s [id 2 1]]]"

declare Pi.simps[simp del]

text ‹
  The correctness of rec_entry›.
›
lemma entry_lemma: "rec_exec rec_entry [str, i] = Entry str i"
  by(simp add: rec_entry_def  rec_exec.simps lo_lemma pi_lemma)


subsection ‹The construction of F›

text ‹
  Using the auxilliary functions obtained in last section, 
  we are going to contruct the function F›, 
  which is an interpreter of Turing Machines.
›

fun listsum2 :: "nat list  nat  nat"
  where
    "listsum2 xs 0 = 0"
  | "listsum2 xs (Suc n) = listsum2 xs n + xs ! n"

fun rec_listsum2 :: "nat  nat  recf"
  where
    "rec_listsum2 vl 0 = Cn vl z [id vl 0]"
  | "rec_listsum2 vl (Suc n) = Cn vl rec_add [rec_listsum2 vl n, id vl n]"

declare listsum2.simps[simp del] rec_listsum2.simps[simp del]

lemma listsum2_lemma: "length xs = vl; n  vl  
      rec_exec (rec_listsum2 vl n) xs = listsum2 xs n"
  apply(induct n, simp_all)
   apply(simp_all add: rec_exec.simps rec_listsum2.simps listsum2.simps)
  done

fun strt' :: "nat list  nat  nat"
  where
    "strt' xs 0 = 0"
  | "strt' xs (Suc n) = (let dbound = listsum2 xs n + n in 
                       strt' xs n + (2^(xs ! n + dbound) - 2^dbound))"

fun rec_strt' :: "nat  nat  recf"
  where
    "rec_strt' vl 0 = Cn vl z [id vl 0]"
  | "rec_strt' vl (Suc n) = (let rec_dbound =
  Cn vl rec_add [rec_listsum2 vl n, Cn vl (constn n) [id vl 0]]
  in Cn vl rec_add [rec_strt' vl n, Cn vl rec_minus 
  [Cn vl rec_power [Cn vl (constn 2) [id vl 0], Cn vl rec_add
  [id vl (n), rec_dbound]], 
  Cn vl rec_power [Cn vl (constn 2) [id vl 0], rec_dbound]]])"

declare strt'.simps[simp del] rec_strt'.simps[simp del]

lemma strt'_lemma: "length xs = vl; n  vl  
  rec_exec (rec_strt' vl n) xs = strt' xs n"
  apply(induct n)
   apply(simp_all add: rec_exec.simps rec_strt'.simps strt'.simps
      Let_def power_lemma listsum2_lemma)
  done

text strt› corresponds to the strt› function on page 90 of B book, but 
  this definition generalises the original one to deal with multiple input arguments.
›
fun strt :: "nat list  nat"
  where
    "strt xs = (let ys = map Suc xs in 
              strt' ys (length ys))"

fun rec_map :: "recf  nat  recf list"
  where
    "rec_map rf vl = map (λ i. Cn vl rf [id vl i]) [0..<vl]"

text rec_strt› is the recursive function used to implement strt›.
›
fun rec_strt :: "nat  recf"
  where
    "rec_strt vl = Cn vl (rec_strt' vl vl) (rec_map s vl)"

lemma map_s_lemma: "length xs = vl  
  map ((λa. rec_exec a xs)  (λi. Cn vl s [recf.id vl i]))
  [0..<vl]
        = map Suc xs"
  apply(induct vl arbitrary: xs, simp, auto simp: rec_exec.simps)
  apply(rename_tac vl xs)
  apply(subgoal_tac " ys y. xs = ys @ [y]", auto)
proof -
  fix ys y
  assume ind: "xs. length xs = length (ys::nat list) 
      map ((λa. rec_exec a xs)  (λi. Cn (length ys) s 
        [recf.id (length ys) (i)])) [0..<length ys] = map Suc xs"
  show
    "map ((λa. rec_exec a (ys @ [y]))  (λi. Cn (Suc (length ys)) s 
  [recf.id (Suc (length ys)) (i)])) [0..<length ys] = map Suc ys"
  proof -
    have "map ((λa. rec_exec a ys)  (λi. Cn (length ys) s
        [recf.id (length ys) (i)])) [0..<length ys] = map Suc ys"
      apply(rule_tac ind, simp)
      done
    moreover have
      "map ((λa. rec_exec a (ys @ [y]))  (λi. Cn (Suc (length ys)) s
           [recf.id (Suc (length ys)) (i)])) [0..<length ys]
         = map ((λa. rec_exec a ys)  (λi. Cn (length ys) s 
                 [recf.id (length ys) (i)])) [0..<length ys]"
      apply(rule_tac map_ext, auto simp: rec_exec.simps nth_append)
      done
    ultimately show "?thesis"
      by simp
  qed
next
  fix vl xs
  assume "length xs = Suc vl"
  thus "ys y. xs = ys @ [y]"
    apply(rule_tac x = "butlast xs" in exI, rule_tac x = "last xs" in exI)
    apply(subgoal_tac "xs  []", auto)
    done
qed

text ‹
  The correctness of rec_strt›.
›
lemma strt_lemma: "length xs = vl  
  rec_exec (rec_strt vl) xs = strt xs"
  apply(simp add: strt.simps rec_exec.simps strt'_lemma)
  apply(subgoal_tac "(map ((λa. rec_exec a xs)  (λi. Cn vl s [recf.id vl (i)])) [0..<vl])
                  = map Suc xs", auto)
  apply(rule map_s_lemma, simp)
  done

text ‹
  The scan› function on page 90 of B book.
›
fun scan :: "nat  nat"
  where
    "scan r = r mod 2"

text rec_scan› is the implemention of scan›.
›
definition rec_scan :: "recf"
  where "rec_scan = Cn 1 rec_mod [id 1 0, constn 2]"

text ‹
  The correctness of scan›.
›
lemma scan_lemma: "rec_exec rec_scan [r] = r mod 2"
  by(simp add: rec_exec.simps rec_scan_def mod_lemma)

fun newleft0 :: "nat list  nat"
  where
    "newleft0 [p, r] = p"

definition rec_newleft0 :: "recf"
  where
    "rec_newleft0 = id 2 0"

fun newrgt0 :: "nat list  nat"
  where
    "newrgt0 [p, r] = r - scan r"

definition rec_newrgt0 :: "recf"
  where
    "rec_newrgt0 = Cn 2 rec_minus [id 2 1, Cn 2 rec_scan [id 2 1]]"

(*newleft1, newrgt1: left rgt number after execute on step*)
fun newleft1 :: "nat list  nat"
  where
    "newleft1 [p, r] = p"

definition rec_newleft1 :: "recf"
  where
    "rec_newleft1 = id 2 0"

fun newrgt1 :: "nat list  nat"
  where
    "newrgt1 [p, r] = r + 1 - scan r"

definition rec_newrgt1 :: "recf"
  where
    "rec_newrgt1 = 
  Cn 2 rec_minus [Cn 2 rec_add [id 2 1, Cn 2 (constn 1) [id 2 0]], 
                  Cn 2 rec_scan [id 2 1]]"

fun newleft2 :: "nat list  nat"
  where
    "newleft2 [p, r] = p div 2"

definition rec_newleft2 :: "recf" 
  where
    "rec_newleft2 = Cn 2 rec_quo [id 2 0, Cn 2 (constn 2) [id 2 0]]"

fun newrgt2 :: "nat list  nat"
  where
    "newrgt2 [p, r] = 2 * r + p mod 2"

definition rec_newrgt2 :: "recf"
  where
    "rec_newrgt2 =
    Cn 2 rec_add [Cn 2 rec_mult [Cn 2 (constn 2) [id 2 0], id 2 1],                     
                 Cn 2 rec_mod [id 2 0, Cn 2 (constn 2) [id 2 0]]]"

fun newleft3 :: "nat list  nat"
  where
    "newleft3 [p, r] = 2 * p + r mod 2"

definition rec_newleft3 :: "recf"
  where
    "rec_newleft3 = 
  Cn 2 rec_add [Cn 2 rec_mult [Cn 2 (constn 2) [id 2 0], id 2 0], 
                Cn 2 rec_mod [id 2 1, Cn 2 (constn 2) [id 2 0]]]"

fun newrgt3 :: "nat list  nat"
  where
    "newrgt3 [p, r] = r div 2"

definition rec_newrgt3 :: "recf"
  where
    "rec_newrgt3 = Cn 2 rec_quo [id 2 1, Cn 2 (constn 2) [id 2 0]]"

text ‹
  The new_left› function on page 91 of B book.
›
fun newleft :: "nat  nat  nat  nat"
  where
    "newleft p r a = (if a = 0  a = 1 then newleft0 [p, r] 
                    else if a = 2 then newleft2 [p, r]
                    else if a = 3 then newleft3 [p, r]
                    else p)"

text rec_newleft› is the recursive function used to 
  implement newleft›.
›
definition rec_newleft :: "recf" 
  where
    "rec_newleft =
  (let g0 = 
      Cn 3 rec_newleft0 [id 3 0, id 3 1] in 
  let g1 = Cn 3 rec_newleft2 [id 3 0, id 3 1] in 
  let g2 = Cn 3 rec_newleft3 [id 3 0, id 3 1] in 
  let g3 = id 3 0 in
  let r0 = Cn 3 rec_disj
          [Cn 3 rec_eq [id 3 2, Cn 3 (constn 0) [id 3 0]],
           Cn 3 rec_eq [id 3 2, Cn 3 (constn 1) [id 3 0]]] in 
  let r1 = Cn 3 rec_eq [id 3 2, Cn 3 (constn 2) [id 3 0]] in 
  let r2 = Cn 3 rec_eq [id 3 2, Cn 3 (constn 3) [id 3 0]] in
  let r3 = Cn 3 rec_less [Cn 3 (constn 3) [id 3 0], id 3 2] in 
  let gs = [g0, g1, g2, g3] in 
  let rs = [r0, r1, r2, r3] in 
  rec_embranch (zip gs rs))"

declare newleft.simps[simp del]


lemma Suc_Suc_Suc_Suc_induct: 
  "i < Suc (Suc (Suc (Suc 0))); i = 0   P i;
    i = 1  P i; i =2  P i; 
    i =3  P i  P i"
  apply(cases i, force)
  apply(cases "i - 1", force)
  apply(cases "i - 1 - 1", force)
  by(cases "i - 1 - 1 - 1", auto simp:numeral)

declare quo_lemma2[simp] mod_lemma[simp]

text ‹
  The correctness of rec_newleft›.
›
lemma newleft_lemma: 
  "rec_exec rec_newleft [p, r, a] = newleft p r a"
proof(simp only: rec_newleft_def Let_def)
  let ?rgs = "[Cn 3 rec_newleft0 [recf.id 3 0, recf.id 3 1], Cn 3 rec_newleft2 
       [recf.id 3 0, recf.id 3 1], Cn 3 rec_newleft3 [recf.id 3 0, recf.id 3 1], recf.id 3 0]"
  let ?rrs = 
    "[Cn 3 rec_disj [Cn 3 rec_eq [recf.id 3 2, Cn 3 (constn 0) 
     [recf.id 3 0]], Cn 3 rec_eq [recf.id 3 2, Cn 3 (constn 1) [recf.id 3 0]]], 
     Cn 3 rec_eq [recf.id 3 2, Cn 3 (constn 2) [recf.id 3 0]],
     Cn 3 rec_eq [recf.id 3 2, Cn 3 (constn 3) [recf.id 3 0]],
     Cn 3 rec_less [Cn 3 (constn 3) [recf.id 3 0], recf.id 3 2]]"
  have k1: "rec_exec (rec_embranch (zip ?rgs ?rrs)) [p, r, a]
                         = Embranch (zip (map rec_exec ?rgs) (map (λr args. 0 < rec_exec r args) ?rrs)) [p, r, a]"
    apply(rule_tac embranch_lemma )
        apply(auto simp: numeral_3_eq_3 numeral_2_eq_2 rec_newleft0_def 
        rec_newleft1_def rec_newleft2_def rec_newleft3_def)+
    apply(cases "a = 0  a = 1", rule_tac x = 0 in exI)
     prefer 2
     apply(cases "a = 2", rule_tac x = "Suc 0" in exI)
      prefer 2
      apply(cases "a = 3", rule_tac x = "2" in exI)
       prefer 2
       apply(cases "a > 3", rule_tac x = "3" in exI, auto)
             apply(auto simp: rec_exec.simps)
        apply(erule_tac [!] Suc_Suc_Suc_Suc_induct, auto simp: rec_exec.simps)
    done
  have k2: "Embranch (zip (map rec_exec ?rgs) (map (λr args. 0 < rec_exec r args) ?rrs)) [p, r, a] = newleft p r a"
    apply(simp add: Embranch.simps)
    apply(simp add: rec_exec.simps)
    apply(auto simp: newleft.simps rec_newleft0_def rec_exec.simps
        rec_newleft1_def rec_newleft2_def rec_newleft3_def)
    done
  from k1 and k2 show 
    "rec_exec (rec_embranch (zip ?rgs ?rrs)) [p, r, a] = newleft p r a"
    by simp
qed

text ‹
  The newrght› function is one similar to newleft›, but used to 
  compute the right number.
›
fun newrght :: "nat  nat  nat  nat"
  where
    "newrght p r a  = (if a = 0 then newrgt0 [p, r]
                    else if a = 1 then newrgt1 [p, r]
                    else if a = 2 then newrgt2 [p, r]
                    else if a = 3 then newrgt3 [p, r]
                    else r)"

text rec_newrght› is the recursive function used to implement 
  newrgth›.
›
definition rec_newrght :: "recf" 
  where
    "rec_newrght =
  (let g0 = Cn 3 rec_newrgt0 [id 3 0, id 3 1] in 
  let g1 = Cn 3 rec_newrgt1 [id 3 0, id 3 1] in 
  let g2 = Cn 3 rec_newrgt2 [id 3 0, id 3 1] in 
  let g3 = Cn 3 rec_newrgt3 [id 3 0, id 3 1] in
  let g4 = id 3 1 in 
  let r0 = Cn 3 rec_eq [id 3 2, Cn 3 (constn 0) [id 3 0]] in 
  let r1 = Cn 3 rec_eq [id 3 2, Cn 3 (constn 1) [id 3 0]] in 
  let r2 = Cn 3 rec_eq [id 3 2, Cn 3 (constn 2) [id 3 0]] in
  let r3 = Cn 3 rec_eq [id 3 2, Cn 3 (constn 3) [id 3 0]] in
  let r4 = Cn 3 rec_less [Cn 3 (constn 3) [id 3 0], id 3 2] in 
  let gs = [g0, g1, g2, g3, g4] in 
  let rs = [r0, r1, r2, r3, r4] in 
  rec_embranch (zip gs rs))"
declare newrght.simps[simp del]

lemma numeral_4_eq_4: "4 = Suc 3"
  by auto

lemma Suc_5_induct: 
  "i < Suc (Suc (Suc (Suc (Suc 0)))); i = 0  P 0;
  i = 1  P 1; i = 2  P 2; i = 3  P 3; i = 4  P 4  P i"
  apply(cases i, force)
  apply(cases "i-1", force)
  apply(cases "i-1-1")
  using less_2_cases numeral by auto


lemma primerec_rec_scan_1[intro]: "primerec rec_scan (Suc 0)"
  apply(auto simp: rec_scan_def, auto)
  done

text ‹
  The correctness of rec_newrght›.
›
lemma newrght_lemma: "rec_exec rec_newrght [p, r, a] = newrght p r a"
proof(simp only: rec_newrght_def Let_def)
  let ?gs' = "[newrgt0, newrgt1, newrgt2, newrgt3, λ zs. zs ! 1]"
  let ?r0 = "λ zs. zs ! 2 = 0"
  let ?r1 = "λ zs. zs ! 2 = 1"
  let ?r2 = "λ zs. zs ! 2 = 2"
  let ?r3 = "λ zs. zs ! 2 = 3"
  let ?r4 = "λ zs. zs ! 2 > 3"
  let ?gs = "map (λ g. (λ zs. g [zs ! 0, zs ! 1])) ?gs'"
  let ?rs = "[?r0, ?r1, ?r2, ?r3, ?r4]"
  let ?rgs = 
    "[Cn 3 rec_newrgt0 [recf.id 3 0, recf.id 3 1],
    Cn 3 rec_newrgt1 [recf.id 3 0, recf.id 3 1],
     Cn 3 rec_newrgt2 [recf.id 3 0, recf.id 3 1], 
      Cn 3 rec_newrgt3 [recf.id 3 0, recf.id 3 1], recf.id 3 1]"
  let ?rrs = 
    "[Cn 3 rec_eq [recf.id 3 2, Cn 3 (constn 0) [recf.id 3 0]], Cn 3 rec_eq [recf.id 3 2, 
    Cn 3 (constn 1) [recf.id 3 0]], Cn 3 rec_eq [recf.id 3 2, Cn 3 (constn 2) [recf.id 3 0]],
     Cn 3 rec_eq [recf.id 3 2, Cn 3 (constn 3) [recf.id 3 0]], 
       Cn 3 rec_less [Cn 3 (constn 3) [recf.id 3 0], recf.id 3 2]]"

  have k1: "rec_exec (rec_embranch (zip ?rgs ?rrs)) [p, r, a]
    = Embranch (zip (map rec_exec ?rgs) (map (λr args. 0 < rec_exec r args) ?rrs)) [p, r, a]"
    apply(rule_tac embranch_lemma)
        apply(auto simp: numeral_3_eq_3 numeral_2_eq_2 rec_newrgt0_def 
        rec_newrgt1_def rec_newrgt2_def rec_newrgt3_def)+
    apply(cases "a = 0", rule_tac x = 0 in exI)
     prefer 2
     apply(cases "a = 1", rule_tac x = "Suc 0" in exI)
      prefer 2
      apply(cases "a = 2", rule_tac x = "2" in exI)
       prefer 2
       apply(cases "a = 3", rule_tac x = "3" in exI)
        prefer 2
        apply(cases "a > 3", rule_tac x = "4" in exI, auto simp: rec_exec.simps)
        apply(erule_tac [!] Suc_5_induct, auto simp: rec_exec.simps)
    done
  have k2: "Embranch (zip (map rec_exec ?rgs)
    (map (λr args. 0 < rec_exec r args) ?rrs)) [p, r, a] = newrght p r a"
    apply(auto simp:Embranch.simps rec_exec.simps)
        apply(auto simp: newrght.simps rec_newrgt3_def rec_newrgt2_def
        rec_newrgt1_def rec_newrgt0_def rec_exec.simps
        scan_lemma)
    done
  from k1 and k2 show 
    "rec_exec (rec_embranch (zip ?rgs ?rrs)) [p, r, a] =      
                                    newrght p r a" by simp
qed

declare Entry.simps[simp del]

text ‹
  The actn› function given on page 92 of B book, which is used to 
  fetch Turing Machine intructions. 
  In actn m q r›, m› is the Godel coding of a Turing Machine,
  q› is the current state of Turing Machine, r› is the
  right number of Turing Machine tape.
›
fun actn :: "nat  nat  nat  nat"
  where
    "actn m q r = (if q  0 then Entry m (4*(q - 1) + 2 * scan r)
                 else 4)"

text rec_actn› is the recursive function used to implement actn›
definition rec_actn :: "recf"
  where
    "rec_actn = 
  Cn 3 rec_add [Cn 3 rec_mult 
        [Cn 3 rec_entry [id 3 0, Cn 3 rec_add [Cn 3 rec_mult 
                                 [Cn 3 (constn 4) [id 3 0], 
                Cn 3 rec_minus [id 3 1, Cn 3 (constn 1) [id 3 0]]], 
                   Cn 3 rec_mult [Cn 3 (constn 2) [id 3 0],
                      Cn 3 rec_scan [id 3 2]]]], 
            Cn 3 rec_noteq [id 3 1, Cn 3 (constn 0) [id 3 0]]], 
                             Cn 3 rec_mult [Cn 3 (constn 4) [id 3 0], 
             Cn 3 rec_eq [id 3 1, Cn 3 (constn 0) [id 3 0]]]] "

text ‹
  The correctness of actn›.
›
lemma actn_lemma: "rec_exec rec_actn [m, q, r] = actn m q r"
  by(auto simp: rec_actn_def rec_exec.simps entry_lemma scan_lemma)

fun newstat :: "nat  nat  nat  nat"
  where
    "newstat m q r = (if q  0 then Entry m (4*(q - 1) + 2*scan r + 1)
                    else 0)"

definition rec_newstat :: "recf"
  where
    "rec_newstat = Cn 3 rec_add 
    [Cn 3 rec_mult [Cn 3 rec_entry [id 3 0, 
           Cn 3 rec_add [Cn 3 rec_mult [Cn 3 (constn 4) [id 3 0], 
           Cn 3 rec_minus [id 3 1, Cn 3 (constn 1) [id 3 0]]], 
           Cn 3 rec_add [Cn 3 rec_mult [Cn 3 (constn 2) [id 3 0],
           Cn 3 rec_scan [id 3 2]], Cn 3 (constn 1) [id 3 0]]]], 
           Cn 3 rec_noteq [id 3 1, Cn 3 (constn 0) [id 3 0]]], 
           Cn 3 rec_mult [Cn 3 (constn 0) [id 3 0], 
           Cn 3 rec_eq [id 3 1, Cn 3 (constn 0) [id 3 0]]]] "

lemma newstat_lemma: "rec_exec rec_newstat [m, q, r] = newstat m q r"
  by(auto simp:  rec_exec.simps entry_lemma scan_lemma rec_newstat_def)

declare newstat.simps[simp del] actn.simps[simp del]

text‹code the configuration›

fun trpl :: "nat  nat  nat  nat"
  where
    "trpl p q r = (Pi 0)^p * (Pi 1)^q * (Pi 2)^r"

definition rec_trpl :: "recf"
  where
    "rec_trpl = Cn 3 rec_mult [Cn 3 rec_mult 
       [Cn 3 rec_power [Cn 3 (constn (Pi 0)) [id 3 0], id 3 0], 
        Cn 3 rec_power [Cn 3 (constn (Pi 1)) [id 3 0], id 3 1]],
        Cn 3 rec_power [Cn 3 (constn (Pi 2)) [id 3 0], id 3 2]]"
declare trpl.simps[simp del]
lemma trpl_lemma: "rec_exec rec_trpl [p, q, r] = trpl p q r"
  by(auto simp: rec_trpl_def rec_exec.simps power_lemma trpl.simps)

text‹left, stat, rght: decode func›
fun left :: "nat  nat"
  where
    "left c = lo c (Pi 0)"

fun stat :: "nat  nat"
  where
    "stat c = lo c (Pi 1)"

fun rght :: "nat  nat"
  where
    "rght c = lo c (Pi 2)"

fun inpt :: "nat  nat list  nat"
  where
    "inpt m xs = trpl 0 1 (strt xs)"

fun newconf :: "nat  nat  nat"
  where
    "newconf m c = trpl (newleft (left c) (rght c) 
                        (actn m (stat c) (rght c)))
                        (newstat m (stat c) (rght c)) 
                        (newrght (left c) (rght c) 
                              (actn m (stat c) (rght c)))"

declare left.simps[simp del] stat.simps[simp del] rght.simps[simp del]
  inpt.simps[simp del] newconf.simps[simp del]

definition rec_left :: "recf"
  where
    "rec_left = Cn 1 rec_lo [id 1 0, constn (Pi 0)]"

definition rec_right :: "recf"
  where
    "rec_right = Cn 1 rec_lo [id 1 0, constn (Pi 2)]"

definition rec_stat :: "recf"
  where
    "rec_stat = Cn 1 rec_lo [id 1 0, constn (Pi 1)]"

definition rec_inpt :: "nat  recf"
  where
    "rec_inpt vl = Cn vl rec_trpl 
                  [Cn vl (constn 0) [id vl 0], 
                   Cn vl (constn 1) [id vl 0], 
                   Cn vl (rec_strt (vl - 1)) 
                        (map (λ i. id vl (i)) [1..<vl])]"

lemma left_lemma: "rec_exec rec_left [c] = left c"
  by(simp add: rec_exec.simps rec_left_def left.simps lo_lemma)

lemma right_lemma: "rec_exec rec_right [c] = rght c"
  by(simp add: rec_exec.simps rec_right_def rght.simps lo_lemma)

lemma stat_lemma: "rec_exec rec_stat [c] = stat c"
  by(simp add: rec_exec.simps rec_stat_def stat.simps lo_lemma)

declare rec_strt.simps[simp del] strt.simps[simp del]

lemma map_cons_eq: 
  "(map ((λa. rec_exec a (m # xs))  
    (λi. recf.id (Suc (length xs)) (i))) 
          [Suc 0..<Suc (length xs)])
        = map (λ i. xs ! (i - 1)) [Suc 0..<Suc (length xs)]"
  apply(rule map_ext, auto)
   apply(auto simp: rec_exec.simps nth_append nth_Cons split: nat.split)
  done

lemma list_map_eq: 
  "vl = length (xs::nat list)  map (λ i. xs ! (i - 1))
                                          [Suc 0..<Suc vl] = xs"
proof(induct vl arbitrary: xs)
  case (Suc vl)
  then show ?case 
    apply(subgoal_tac " ys y. xs = ys @ [y]", auto)
  proof -
    fix ys y
    assume ind: 
      "xs. length (ys::nat list) = length (xs::nat list) 
            map (λi. xs ! (i - Suc 0)) [Suc 0..<length xs] @
                                [xs ! (length xs - Suc 0)] = xs"
      and h: "Suc 0  length (ys::nat list)"
    have "map (λi. ys ! (i - Suc 0)) [Suc 0..<length ys] @ 
                                   [ys ! (length ys - Suc 0)] = ys"
      apply(rule_tac ind, simp)
      done
    moreover have 
      "map (λi. (ys @ [y]) ! (i - Suc 0)) [Suc 0..<length ys]
      = map (λi. ys ! (i - Suc 0)) [Suc 0..<length ys]"
      apply(rule map_ext)
      using h
      apply(auto simp: nth_append)
      done
    ultimately show "map (λi. (ys @ [y]) ! (i - Suc 0)) 
        [Suc 0..<length ys] @ [(ys @ [y]) ! (length ys - Suc 0)] = ys"
      apply(simp del: map_eq_conv add: nth_append, auto)
      using h
      apply(simp)
      done
  next
    fix vl xs
    assume "Suc vl = length (xs::nat list)"
    thus "ys y. xs = ys @ [y]"
      apply(rule_tac x = "butlast xs" in exI, 
          rule_tac x = "last xs" in exI)
      apply(cases "xs  []", auto)
      done
  qed
qed simp

lemma nonempty_listE: 
  "Suc 0  length xs  
     (map ((λa. rec_exec a (m # xs))  
         (λi. recf.id (Suc (length xs)) (i))) 
             [Suc 0..<length xs] @ [(m # xs) ! length xs]) = xs"
  using map_cons_eq[of m xs]
  apply(simp del: map_eq_conv add: rec_exec.simps)
  using list_map_eq[of "length xs" xs]
  apply(simp)
  done

lemma inpt_lemma:
  "Suc (length xs) = vl  
            rec_exec (rec_inpt vl) (m # xs) = inpt m xs"
  apply(auto simp: rec_exec.simps rec_inpt_def 
      trpl_lemma inpt.simps strt_lemma)
   apply(subgoal_tac
      "(map ((λa. rec_exec a (m # xs))  
          (λi. recf.id (Suc (length xs)) (i))) 
            [Suc 0..<length xs] @ [(m # xs) ! length xs]) = xs", simp)
   apply(auto elim:nonempty_listE, cases xs, auto)
  done

definition rec_newconf:: "recf"
  where
    "rec_newconf = 
    Cn 2 rec_trpl 
        [Cn 2 rec_newleft [Cn 2 rec_left [id 2 1], 
                           Cn 2 rec_right [id 2 1], 
                           Cn 2 rec_actn [id 2 0, 
                                          Cn 2 rec_stat [id 2 1], 
                           Cn 2 rec_right [id 2 1]]],
          Cn 2 rec_newstat [id 2 0, 
                            Cn 2 rec_stat [id 2 1], 
                            Cn 2 rec_right [id 2 1]],
           Cn 2 rec_newrght [Cn 2 rec_left [id 2 1], 
                             Cn 2 rec_right [id 2 1], 
                             Cn 2 rec_actn [id 2 0, 
                                   Cn 2 rec_stat [id 2 1], 
                             Cn 2 rec_right [id 2 1]]]]"

lemma newconf_lemma: "rec_exec rec_newconf [m ,c] = newconf m c"
  by(auto simp: rec_newconf_def rec_exec.simps 
      trpl_lemma newleft_lemma left_lemma
      right_lemma stat_lemma newrght_lemma actn_lemma 
      newstat_lemma newconf.simps)

declare newconf_lemma[simp]

text conf m r k› computes the TM configuration after k› steps of execution
  of TM coded as m› starting from the initial configuration where the left number equals 0›, 
  right number equals r›. 
›
fun conf :: "nat  nat  nat  nat"
  where
    "conf m r 0 = trpl 0 (Suc 0) r"
  | "conf m r (Suc t) = newconf m (conf m r t)"

declare conf.simps[simp del]

text conf› is implemented by the following recursive function rec_conf›.
›
definition rec_conf :: "recf"
  where
    "rec_conf = Pr 2 (Cn 2 rec_trpl [Cn 2 (constn 0) [id 2 0], Cn 2 (constn (Suc 0)) [id 2 0], id 2 1])
                  (Cn 4 rec_newconf [id 4 0, id 4 3])"

lemma conf_step: 
  "rec_exec rec_conf [m, r, Suc t] =
         rec_exec rec_newconf [m, rec_exec rec_conf [m, r, t]]"
proof -
  have "rec_exec rec_conf ([m, r] @ [Suc t]) = 
          rec_exec rec_newconf [m, rec_exec rec_conf [m, r, t]]"
    by(simp only: rec_conf_def rec_pr_Suc_simp_rewrite,
        simp add: rec_exec.simps)
  thus "rec_exec rec_conf [m, r, Suc t] =
                rec_exec rec_newconf [m, rec_exec rec_conf [m, r, t]]"
    by simp
qed

text ‹
  The correctness of rec_conf›.
›
lemma conf_lemma: 
  "rec_exec rec_conf [m, r, t] = conf m r t"
  by (induct t)
    (auto simp add: rec_conf_def rec_exec.simps conf.simps inpt_lemma trpl_lemma)

text NSTD c› returns true if the configureation coded by c› is no a stardard
  final configuration.
›
fun NSTD :: "nat  bool"
  where
    "NSTD c = (stat c  0  left c  0  
             rght c  2^(lg (rght c + 1) 2) - 1  rght c = 0)"

text rec_NSTD› is the recursive function implementing NSTD›.
›
definition rec_NSTD :: "recf"
  where
    "rec_NSTD =
     Cn 1 rec_disj [
          Cn 1 rec_disj [
             Cn 1 rec_disj 
                [Cn 1 rec_noteq [rec_stat, constn 0], 
                 Cn 1 rec_noteq [rec_left, constn 0]] , 
              Cn 1 rec_noteq [rec_right,  
                              Cn 1 rec_minus [Cn 1 rec_power 
                                 [constn 2, Cn 1 rec_lg 
                                    [Cn 1 rec_add        
                                     [rec_right, constn 1], 
                                            constn 2]], constn 1]]],
               Cn 1 rec_eq [rec_right, constn 0]]"

lemma NSTD_lemma1: "rec_exec rec_NSTD [c] = Suc 0 
                   rec_exec rec_NSTD [c] = 0"
  by(simp add: rec_exec.simps rec_NSTD_def)

declare NSTD.simps[simp del]
lemma NSTD_lemma2': "(rec_exec rec_NSTD [c] = Suc 0)  NSTD c"
  apply(simp add: rec_exec.simps rec_NSTD_def stat_lemma left_lemma 
      lg_lemma right_lemma power_lemma NSTD.simps)
  apply(auto)
  apply(cases "0 < left c", simp, simp)
  done

lemma NSTD_lemma2'': 
  "NSTD c  (rec_exec rec_NSTD [c] = Suc 0)"
  apply(simp add: rec_exec.simps rec_NSTD_def stat_lemma 
      left_lemma lg_lemma right_lemma power_lemma NSTD.simps)
  apply(auto split: if_splits)
  done

text ‹
  The correctness of NSTD›.
›
lemma NSTD_lemma2: "(rec_exec rec_NSTD [c] = Suc 0) = NSTD c"
  using NSTD_lemma1
  apply(auto intro: NSTD_lemma2' NSTD_lemma2'')
  done

fun nstd :: "nat  nat"
  where
    "nstd c = (if NSTD c then 1 else 0)"

lemma nstd_lemma: "rec_exec rec_NSTD [c] = nstd c"
  using NSTD_lemma1
  apply(simp add: NSTD_lemma2, auto)
  done

textnonstep m r t› means afer t› steps of execution, the TM coded by m›
  is not at a stardard final configuration.
›
fun nonstop :: "nat  nat   nat  nat"
  where
    "nonstop m r t = nstd (conf m r t)"

text rec_nonstop› is the recursive function implementing nonstop›.
›
definition rec_nonstop :: "recf"
  where
    "rec_nonstop = Cn 3 rec_NSTD [rec_conf]"

text ‹
  The correctness of rec_nonstop›.
›
lemma nonstop_lemma: 
  "rec_exec rec_nonstop [m, r, t] = nonstop m r t"
  apply(simp add: rec_exec.simps rec_nonstop_def nstd_lemma conf_lemma)
  done

textrec_halt› is the recursive function calculating the steps a TM needs to execute before
  to reach a stardard final configuration. This recursive function is the only one
  using Mn› combinator. So it is the only non-primitive recursive function 
  needs to be used in the construction of the universal function F›.
›

definition rec_halt :: "recf"
  where
    "rec_halt = Mn (Suc (Suc 0)) (rec_nonstop)"

declare nonstop.simps[simp del]

text ‹
  The lemma relates the interpreter of primitive functions with
  the calculation relation of general recursive functions. 
›

declare numeral_2_eq_2[simp] numeral_3_eq_3[simp]

lemma primerec_rec_right_1[intro]: "primerec rec_right (Suc 0)"
  by(auto simp: rec_right_def rec_lo_def Let_def;force)

lemma primerec_rec_pi_helper:
  "i<Suc (Suc 0). primerec ([recf.id (Suc 0) 0, recf.id (Suc 0) 0] ! i) (Suc 0)"
  by fastforce

lemmas primerec_rec_pi_helpers =
  primerec_rec_pi_helper primerec_constn_1 primerec_rec_sg_1 primerec_rec_not_1 primerec_rec_conj_2

lemma primrec_dummyfac:
  "i<Suc (Suc 0).
       primerec
        ([recf.id (Suc 0) 0,
          Cn (Suc 0) s
           [Cn (Suc 0) rec_dummyfac
             [recf.id (Suc 0) 0, recf.id (Suc 0) 0]]] !
         i)
        (Suc 0)"
  by(auto simp: rec_dummyfac_def;force)

lemma primerec_rec_pi_1[intro]:  "primerec rec_pi (Suc 0)"
  apply(simp add: rec_pi_def rec_dummy_pi_def 
      rec_np_def rec_fac_def rec_prime_def
      rec_Minr.simps Let_def get_fstn_args.simps
      arity.simps
      rec_all.simps rec_sigma.simps rec_accum.simps)
  apply(tactic ‹resolve_tac @{context} [@{thm prime_cn},  @{thm prime_pr}] 1
      ;(simp add:primerec_rec_pi_helpers primrec_dummyfac)?)+
  by fastforce+

lemma primerec_recs[intro]:
  "primerec rec_trpl (Suc (Suc (Suc 0)))"
  "primerec rec_newleft0 (Suc (Suc 0))"
  "primerec rec_newleft1 (Suc (Suc 0))"
  "primerec rec_newleft2 (Suc (Suc 0))"
  "primerec rec_newleft3 (Suc (Suc 0))"
  "primerec rec_newleft (Suc (Suc (Suc 0)))"
  "primerec rec_left (Suc 0)"
  "primerec rec_actn (Suc (Suc (Suc 0)))"
  "primerec rec_stat (Suc 0)"
  "primerec rec_newstat (Suc (Suc (Suc 0)))"
           apply(simp_all add: rec_newleft_def rec_embranch.simps rec_left_def rec_lo_def rec_entry_def
      rec_actn_def Let_def arity.simps rec_newleft0_def rec_stat_def rec_newstat_def
      rec_newleft1_def rec_newleft2_def rec_newleft3_def rec_trpl_def)
           apply(tactic ‹resolve_tac @{context} [@{thm prime_cn}, 
    @{thm prime_id}, @{thm prime_pr}] 1;force)+
  done

lemma primerec_rec_newrght[intro]: "primerec rec_newrght (Suc (Suc (Suc 0)))"
  apply(simp add: rec_newrght_def rec_embranch.simps
      Let_def arity.simps rec_newrgt0_def 
      rec_newrgt1_def rec_newrgt2_def rec_newrgt3_def)
  apply(tactic ‹resolve_tac @{context} [@{thm prime_cn}, 
    @{thm prime_id}, @{thm prime_pr}] 1;force)+
  done

lemma primerec_rec_newconf[intro]: "primerec rec_newconf (Suc (Suc 0))"
  apply(simp add: rec_newconf_def)
  by(tactic ‹resolve_tac @{context} [@{thm prime_cn}, 
    @{thm prime_id}, @{thm prime_pr}] 1;force)

lemma primerec_rec_conf[intro]: "primerec rec_conf (Suc (Suc (Suc 0)))"
  apply(simp add: rec_conf_def)
  by(tactic ‹resolve_tac @{context} [@{thm prime_cn}, 
    @{thm prime_id}, @{thm prime_pr}] 1;force simp: numeral)

lemma primerec_recs2[intro]:
  "primerec rec_lg (Suc (Suc 0))"
  "primerec rec_nonstop (Suc (Suc (Suc 0)))"
   apply(simp_all add: rec_lg_def rec_nonstop_def rec_NSTD_def rec_stat_def
      rec_lo_def Let_def rec_left_def rec_right_def rec_newconf_def
      rec_newstat_def)
  by(tactic ‹resolve_tac @{context} [@{thm prime_cn}, 
    @{thm prime_id}, @{thm prime_pr}] 1;fastforce)+

lemma primerec_terminate: 
  "primerec f x; length xs = x  terminate f xs"
proof(induct arbitrary: xs rule: primerec.induct)
  fix xs
  assume "length (xs::nat list) = Suc 0"  thus "terminate z xs"
    by(cases xs, auto intro: termi_z)
next
  fix xs
  assume "length (xs::nat list) = Suc 0" thus "terminate s xs"
    by(cases xs, auto intro: termi_s)
next
  fix n m xs
  assume "n < m" "length (xs::nat list) = m"  thus "terminate (id m n) xs"
    by(erule_tac termi_id, simp)
next
  fix f k gs m n xs
  assume ind: "i<length gs. primerec (gs ! i) m  (x. length x = m  terminate (gs ! i) x)"
    and ind2: " xs. length xs = k  terminate f xs"
    and h: "primerec f k"  "length gs = k" "m = n" "length (xs::nat list) = m"
  have "terminate f (map (λg. rec_exec g xs) gs)"
    using ind2[of "(map (λg. rec_exec g xs) gs)"] h
    by simp
  moreover have "gset gs. terminate g xs"
    using ind h
    by(auto simp: set_conv_nth)
  ultimately show "terminate (Cn n f gs) xs"
    using h
    by(rule_tac termi_cn, auto)
next
  fix f n g m xs
  assume ind1: "xs. length xs = n  terminate f xs"
    and ind2: "xs. length xs = Suc (Suc n)  terminate g xs"
    and h: "primerec f n" " primerec g (Suc (Suc n))" " m = Suc n" "length (xs::nat list) = m"
  have "y<last xs. terminate g (butlast xs @ [y, rec_exec (Pr n f g) (butlast xs @ [y])])"
    using h ind2 by(auto)
  moreover have "terminate f (butlast xs)"
    using ind1[of "butlast xs"] h
    by simp
  moreover have "length (butlast xs) = n"
    using h by simp
  ultimately have "terminate (Pr n f g) (butlast xs @ [last xs])"
    by(rule_tac termi_pr, simp_all)
  thus "terminate (Pr n f g) xs"
    using h
    by(cases "xs = []", auto)
qed

text ‹
  The following lemma gives the correctness of rec_halt›.
  It says: if rec_halt› calculates that the TM coded by m›
  will reach a standard final configuration after t› steps of execution, then it is indeed so.
›

text ‹F: universal machine›

text valu r› extracts computing result out of the right number r›.
›
fun valu :: "nat  nat"
  where
    "valu r = (lg (r + 1) 2) - 1"

text rec_valu› is the recursive function implementing valu›.
›
definition rec_valu :: "recf"
  where
    "rec_valu = Cn 1 rec_minus [Cn 1 rec_lg [s, constn 2], constn 1]"

text ‹
  The correctness of rec_valu›.
›
lemma value_lemma: "rec_exec rec_valu [r] = valu r"
  by(simp add: rec_exec.simps rec_valu_def lg_lemma)

lemma primerec_rec_valu_1[intro]: "primerec rec_valu (Suc 0)"
  unfolding rec_valu_def
  apply(rule prime_cn[of _ "Suc (Suc 0)"])
  by auto auto

declare valu.simps[simp del]

text ‹
  The definition of the universal function rec_F›.
›
definition rec_F :: "recf"
  where
    "rec_F = Cn (Suc (Suc 0)) rec_valu [Cn (Suc (Suc 0)) rec_right [Cn (Suc (Suc 0))
 rec_conf ([id (Suc (Suc 0)) 0, id (Suc (Suc 0)) (Suc 0), rec_halt])]]"

lemma terminate_halt_lemma: 
  "rec_exec rec_nonstop ([m, r] @ [t]) = 0; 
     i<t. 0 < rec_exec rec_nonstop ([m, r] @ [i])  terminate rec_halt [m, r]"
  apply(simp add: rec_halt_def)
  apply(rule termi_mn, auto)
  by(rule primerec_terminate; auto)+


text ‹
  The correctness of rec_F›, halt case.
›

lemma F_lemma: "rec_exec rec_halt [m, r] = t  rec_exec rec_F [m, r] = (valu (rght (conf m r t)))"
  by(simp add: rec_F_def rec_exec.simps value_lemma right_lemma conf_lemma halt_lemma)

lemma terminate_F_lemma: "terminate rec_halt [m, r]  terminate rec_F [m, r]"
  apply(simp add: rec_F_def)
  apply(rule termi_cn, auto)
   apply(rule primerec_terminate, auto)
  apply(rule termi_cn, auto)
   apply(rule primerec_terminate, auto)
  apply(rule termi_cn, auto)
    apply(rule primerec_terminate, auto)
   apply(rule termi_id;force)
  apply(rule termi_id;force)
  done

text ‹
  The correctness of rec_F›, nonhalt case.
›

subsection ‹Coding function of TMs›

text ‹
  The purpose of this section is to get the coding function of Turing Machine, which is 
  going to be named code›.
›

fun bl2nat :: "cell list  nat  nat"
  where
    "bl2nat [] n = 0"
  | "bl2nat (Bk#bl) n = bl2nat bl (Suc n)"
  | "bl2nat (Oc#bl) n = 2^n + bl2nat bl (Suc n)"

fun bl2wc :: "cell list  nat"
  where
    "bl2wc xs = bl2nat xs 0"

fun trpl_code :: "config  nat"
  where
    "trpl_code (st, l, r) = trpl (bl2wc l) st (bl2wc r)"

declare bl2nat.simps[simp del] bl2wc.simps[simp del]
  trpl_code.simps[simp del]

fun action_map :: "action  nat"
  where
    "action_map W0 = 0"
  | "action_map W1 = 1"
  | "action_map L = 2"
  | "action_map R = 3"
  | "action_map Nop = 4"

fun action_map_iff :: "nat  action"
  where
    "action_map_iff (0::nat) = W0"
  | "action_map_iff (Suc 0) = W1"
  | "action_map_iff (Suc (Suc 0)) = L"
  | "action_map_iff (Suc (Suc (Suc 0))) = R"
  | "action_map_iff n = Nop"

fun block_map :: "cell  nat"
  where
    "block_map Bk = 0"
  | "block_map Oc = 1"

fun godel_code' :: "nat list  nat  nat"
  where
    "godel_code' [] n = 1"
  | "godel_code' (x#xs) n = (Pi n)^x * godel_code' xs (Suc n) "

fun godel_code :: "nat list  nat"
  where
    "godel_code xs = (let lh = length xs in 
                   2^lh * (godel_code' xs (Suc 0)))"

fun modify_tprog :: "instr list  nat list"
  where
    "modify_tprog [] =  []"
  | "modify_tprog ((ac, ns)#nl) = action_map ac # ns # modify_tprog nl"

text code tp› gives the Godel coding of TM program tp›.
›
fun code :: "instr list  nat"
  where 
    "code tp = (let nl = modify_tprog tp in 
              godel_code nl)"

subsection ‹Relating interperter functions to the execution of TMs›

lemma bl2wc_0[simp]: "bl2wc [] = 0" by(simp add: bl2wc.simps bl2nat.simps)

lemma fetch_action_map_4[simp]: "fetch tp 0 b = (nact, ns)  action_map nact = 4"
  apply(simp add: fetch.simps)
  done

lemma Pi_gr_1[simp]: "Pi n > Suc 0"
proof(induct n, auto simp: Pi.simps Np.simps)
  fix n
  let ?setx = "{y. y  Suc (Pi n!)  Pi n < y  Prime y}"
  have "finite ?setx" by auto
  moreover have "?setx  {}"
    using prime_ex[of "Pi n"]
    apply(auto)
    done
  ultimately show "Suc 0 < Min ?setx"
    apply(simp add: Min_gr_iff)
    apply(auto simp: Prime.simps)
    done
qed

lemma Pi_not_0[simp]: "Pi n > 0"
  using Pi_gr_1[of n]
  by arith

declare godel_code.simps[simp del]

lemma godel_code'_nonzero[simp]: "0 < godel_code' nl n"
  apply(induct nl arbitrary: n)
   apply(auto simp: godel_code'.simps)
  done

lemma godel_code_great: "godel_code nl > 0"
  apply(simp add: godel_code.simps)
  done

lemma godel_code_eq_1: "(godel_code nl = 1) = (nl = [])"
  apply(auto simp: godel_code.simps)
  done

lemma godel_code_1_iff[elim]: 
  "i < length nl; ¬ Suc 0 < godel_code nl  nl ! i = 0"
  using godel_code_great[of nl] godel_code_eq_1[of nl]
  apply(simp)
  done

lemma prime_coprime: "Prime x; Prime y; xy  coprime x y"
proof (simp only: Prime.simps coprime_def, auto simp: dvd_def,
    rule_tac classical, simp)
  fix d k ka
  assume case_ka: "u<d * ka. v<d * ka. u * v  d * ka" 
    and case_k: "u<d * k. v<d * k. u * v  d * k"
    and h: "(0::nat) < d" "d  Suc 0" "Suc 0 < d * ka" 
    "ka  k" "Suc 0 < d * k"
  from h have "k > Suc 0  ka >Suc 0"
    by (cases ka;cases k;force+)
  from this show "False"
  proof(erule_tac disjE)
    assume  "(Suc 0::nat) < k"
    hence "k < d*k  d < d*k"
      using h
      by(auto)
    thus "?thesis"
      using case_k
      apply(erule_tac x = d in allE)
      apply(simp)
      apply(erule_tac x = k in allE)
      apply(simp)
      done
  next
    assume "(Suc 0::nat) < ka"
    hence "ka < d * ka  d < d*ka"
      using h by auto
    thus "?thesis"
      using case_ka
      apply(erule_tac x = d in allE)
      apply(simp)
      apply(erule_tac x = ka in allE)
      apply(simp)
      done
  qed
qed

lemma Pi_inc: "Pi (Suc i) > Pi i"
proof(simp add: Pi.simps Np.simps)
  let ?setx = "{y. y  Suc (Pi i!)  Pi i < y  Prime y}"
  have "finite ?setx" by simp
  moreover have "?setx  {}"
    using prime_ex[of "Pi i"]
    apply(auto)
    done
  ultimately show "Pi i < Min ?setx"
    apply(simp)
    done
qed    

lemma Pi_inc_gr: "i < j  Pi i < Pi j"
proof(induct j, simp)
  fix j
  assume ind: "i < j  Pi i < Pi j"
    and h: "i < Suc j"
  from h show "Pi i < Pi (Suc j)"
  proof(cases "i < j")
    case True thus "?thesis"
    proof -
      assume "i < j"
      hence "Pi i < Pi j" by(erule_tac ind)
      moreover have "Pi j < Pi (Suc j)"
        apply(simp add: Pi_inc)
        done
      ultimately show "?thesis"
        by simp
    qed
  next
    assume "i < Suc j" "¬ i < j"
    hence "i = j"
      by arith
    thus "Pi i < Pi (Suc j)"
      apply(simp add: Pi_inc)
      done
  qed
qed      

lemma Pi_notEq: "i  j  Pi i  Pi j"
  apply(cases "i < j")
  using Pi_inc_gr[of i j]
   apply(simp)
  using Pi_inc_gr[of j i]
  apply(simp)
  done

lemma prime_2[intro]: "Prime (Suc (Suc 0))"
  apply(auto simp: Prime.simps)
  using less_2_cases by fastforce

lemma Prime_Pi[intro]: "Prime (Pi n)"
proof(induct n, auto simp: Pi.simps Np.simps)
  fix n
  let ?setx = "{y. y  Suc (Pi n!)  Pi n < y  Prime y}"
  show "Prime (Min ?setx)"
  proof -
    have "finite ?setx" by simp
    moreover have "?setx  {}" 
      using prime_ex[of "Pi n"]
      apply(simp)
      done
    ultimately show "?thesis"
      apply(drule_tac Min_in, simp, simp)
      done
  qed
qed

lemma Pi_coprime: "i  j  coprime (Pi i) (Pi j)"
  using Prime_Pi[of i]
  using Prime_Pi[of j]
  apply(rule_tac prime_coprime, simp_all add: Pi_notEq)
  done

lemma Pi_power_coprime: "i  j  coprime ((Pi i)^m) ((Pi j)^n)"
  unfolding coprime_power_right_iff coprime_power_left_iff using Pi_coprime by auto

lemma coprime_dvd_mult_nat2: "coprime (k::nat) n; k dvd n * m  k dvd m"
  unfolding coprime_dvd_mult_right_iff.

declare godel_code'.simps[simp del]

lemma godel_code'_butlast_last_id' :
  "godel_code' (ys @ [y]) (Suc j) = godel_code' ys (Suc j) * 
                                Pi (Suc (length ys + j)) ^ y"
proof(induct ys arbitrary: j, simp_all add: godel_code'.simps)
qed  

lemma godel_code'_butlast_last_id: 
  "xs  []  godel_code' xs (Suc j) = 
  godel_code' (butlast xs) (Suc j) * Pi (length xs + j)^(last xs)"
  apply(subgoal_tac " ys y. xs = ys @ [y]")
   apply(erule_tac exE, erule_tac exE, simp add: 
      godel_code'_butlast_last_id')
  apply(rule_tac x = "butlast xs" in exI)
  apply(rule_tac x = "last xs" in exI, auto)
  done

lemma godel_code'_not0: "godel_code' xs n  0"
  apply(induct xs, auto simp: godel_code'.simps)
  done

lemma godel_code_append_cons: 
  "length xs = i  godel_code' (xs@y#ys) (Suc 0)
    = godel_code' xs (Suc 0) * Pi (Suc i)^y * godel_code' ys (i + 2)"
proof(induct "length xs" arbitrary: i y ys xs, simp add: godel_code'.simps,simp)
  fix x xs i y ys
  assume ind: 
    "xs i y ys. x = i; length xs = i  
       godel_code' (xs @ y # ys) (Suc 0) 
     = godel_code' xs (Suc 0) * Pi (Suc i) ^ y * 
                             godel_code' ys (Suc (Suc i))"
    and h: "Suc x = i" 
    "length (xs::nat list) = i"
  have 
    "godel_code' (butlast xs @ last xs # ((y::nat)#ys)) (Suc 0) = 
        godel_code' (butlast xs) (Suc 0) * Pi (Suc (i - 1))^(last xs) 
              * godel_code' (y#ys) (Suc (Suc (i - 1)))"
    apply(rule_tac ind)
    using h
    by(auto)
  moreover have 
    "godel_code' xs (Suc 0)= godel_code' (butlast xs) (Suc 0) *
                                                  Pi (i)^(last xs)"
    using godel_code'_butlast_last_id[of xs] h
    apply(cases "xs = []", simp, simp)
    done 
  moreover have "butlast xs @ last xs # y # ys = xs @ y # ys"
    using h
    apply(cases xs, auto)
    done
  ultimately show 
    "godel_code' (xs @ y # ys) (Suc 0) =
               godel_code' xs (Suc 0) * Pi (Suc i) ^ y *
                    godel_code' ys (Suc (Suc i))"
    using h
    apply(simp add: godel_code'_not0 Pi_not_0)
    apply(simp add: godel_code'.simps)
    done
qed

lemma Pi_coprime_pre: 
  "length ps  i  coprime (Pi (Suc i)) (godel_code' ps (Suc 0))"
proof(induct "length ps" arbitrary: ps)
  fix x ps
  assume ind: 
    "ps. x = length ps; length ps  i 
                  coprime (Pi (Suc i)) (godel_code' ps (Suc 0))"
    and h: "Suc x = length ps"
    "length (ps::nat list)  i"
  have g: "coprime (Pi (Suc i)) (godel_code' (butlast ps) (Suc 0))"
    apply(rule_tac ind)
    using h by auto
  have k: "godel_code' ps (Suc 0) = 
         godel_code' (butlast ps) (Suc 0) * Pi (length ps)^(last ps)"
    using godel_code'_butlast_last_id[of ps 0] h 
    by(cases ps, simp, simp)
  from g have "coprime (Pi (Suc i)) (Pi (length ps) ^ last ps)"
    unfolding coprime_power_right_iff using Pi_coprime h(2) by auto
  with g have 
    "coprime (Pi (Suc i)) (godel_code' (butlast ps) (Suc 0) *
                                        Pi (length ps)^(last ps)) "
    unfolding coprime_mult_right_iff coprime_power_right_iff by auto

  from this and k show "coprime (Pi (Suc i)) (godel_code' ps (Suc 0))"
    by simp
qed (auto simp add: godel_code'.simps)

lemma Pi_coprime_suf: "i < j  coprime (Pi i) (godel_code' ps j)"
proof(induct "length ps" arbitrary: ps)
  fix x ps
  assume ind: 
    "ps. x = length ps; i < j  
                    coprime (Pi i) (godel_code' ps j)"
    and h: "Suc x = length (ps::nat list)" "i < j"
  have g: "coprime (Pi i) (godel_code' (butlast ps) j)"
    apply(rule ind) using h by auto
  have k: "(godel_code' ps j) = godel_code' (butlast ps) j *
                                 Pi (length ps + j - 1)^last ps"
    using h godel_code'_butlast_last_id[of ps "j - 1"]
    apply(cases "ps = []", simp, simp)
    done
  from g have
    "coprime (Pi i) (godel_code' (butlast ps) j * 
                          Pi (length ps + j - 1)^last ps)"
    using Pi_power_coprime[of i "length ps + j - 1" 1 "last ps"] h
    by(auto)
  from k and this show "coprime (Pi i) (godel_code' ps j)"
    by auto
qed (simp add: godel_code'.simps)

lemma godel_finite: 
  "finite {u. Pi (Suc i) ^ u dvd godel_code' nl (Suc 0)}"
proof(rule bounded_nat_set_is_finite[of _ "godel_code' nl (Suc 0)",rule_format],goal_cases)
  case (1 ia)
  then show ?case proof(cases "ia < godel_code' nl (Suc 0)")
    case False
    hence g1: "Pi (Suc i) ^ ia dvd godel_code' nl (Suc 0)"
      and g2: "¬ ia < godel_code' nl (Suc 0)"
      and "Pi (Suc i)^ia  godel_code' nl (Suc 0)"
      using godel_code'_not0[of nl "Suc 0"] using 1 by (auto elim:dvd_imp_le)
    moreover have "ia < Pi (Suc i)^ia"
      by(rule x_less_exp[OF Pi_gr_1])
    ultimately show ?thesis
      using g2 by(auto)
  qed auto
qed

lemma godel_code_in: 
  "i < length nl   nl ! i   {u. Pi (Suc i) ^ u dvd
                                     godel_code' nl (Suc 0)}"
proof -
  assume h: "i<length nl"
  hence "godel_code' (take i nl@(nl!i)#drop (Suc i) nl) (Suc 0)
           = godel_code' (take i nl) (Suc 0) *  Pi (Suc i)^(nl!i) *
                               godel_code' (drop (Suc i) nl) (i + 2)"
    by(rule_tac godel_code_append_cons, simp)
  moreover from h have "take i nl @ (nl ! i) # drop (Suc i) nl = nl"
    using upd_conv_take_nth_drop[of i nl "nl ! i"]
    by simp
  ultimately  show 
    "nl ! i  {u. Pi (Suc i) ^ u dvd godel_code' nl (Suc 0)}"
    by(simp)
qed

lemma godel_code'_get_nth:
  "i < length nl  Max {u. Pi (Suc i) ^ u dvd 
                          godel_code' nl (Suc 0)} = nl ! i"
proof(rule_tac Max_eqI)
  let ?gc = "godel_code' nl (Suc 0)"
  assume h: "i < length nl" thus "finite {u. Pi (Suc i) ^ u dvd ?gc}"
    by (simp add: godel_finite)  
next
  fix y
  let ?suf ="godel_code' (drop (Suc i) nl) (i + 2)"
  let ?pref = "godel_code' (take i nl) (Suc 0)"
  assume h: "i < length nl" 
    "y  {u. Pi (Suc i) ^ u dvd godel_code' nl (Suc 0)}"
  moreover hence
    "godel_code' (take i nl@(nl!i)#drop (Suc i) nl) (Suc 0)
    = ?pref * Pi (Suc i)^(nl!i) * ?suf"
    by(rule_tac godel_code_append_cons, simp)
  moreover from h have "take i nl @ (nl!i) # drop (Suc i) nl = nl"
    using upd_conv_take_nth_drop[of i nl "nl!i"]
    by simp
  ultimately show "ynl!i"
  proof(simp)
    let ?suf' = "godel_code' (drop (Suc i) nl) (Suc (Suc i))"
    assume mult_dvd: 
      "Pi (Suc i) ^ y dvd ?pref *  Pi (Suc i) ^ nl ! i * ?suf'"
    hence "Pi (Suc i) ^ y dvd ?pref * Pi (Suc i) ^ nl ! i"
    proof -
      have "coprime (Pi (Suc i)^y) ?suf'" by (simp add: Pi_coprime_suf)
      thus ?thesis using coprime_dvd_mult_left_iff mult_dvd by blast
    qed
    hence "Pi (Suc i) ^ y dvd Pi (Suc i) ^ nl ! i"
    proof(rule_tac coprime_dvd_mult_nat2)
      have "coprime (Pi (Suc i)^y) (?pref^Suc 0)" using Pi_coprime_pre by simp
      thus "coprime (Pi (Suc i) ^ y) ?pref" by simp
    qed
    hence "Pi (Suc i) ^ y   Pi (Suc i) ^ nl ! i "
      apply(rule_tac dvd_imp_le, auto)
      done
    thus "y  nl ! i"
      apply(rule_tac power_le_imp_le_exp, auto)
      done
  qed
next
  assume h: "i<length nl"

  thus "nl ! i  {u. Pi (Suc i) ^ u dvd godel_code' nl (Suc 0)}"
    by(rule_tac godel_code_in, simp)
qed

lemma godel_code'_set[simp]: 
  "{u. Pi (Suc i) ^ u dvd (Suc (Suc 0)) ^ length nl * 
                                     godel_code' nl (Suc 0)} = 
    {u. Pi (Suc i) ^ u dvd  godel_code' nl (Suc 0)}"
  apply(rule_tac Collect_cong, auto)
  apply(rule_tac n = " (Suc (Suc 0)) ^ length nl" in 
      coprime_dvd_mult_nat2)
proof -
  have "Pi 0 = (2::nat)" by(simp add: Pi.simps)
  show "coprime (Pi (Suc i) ^ u) ((Suc (Suc 0)) ^ length nl)" for u
    using Pi_coprime Pi.simps(1) by force
qed

lemma godel_code_get_nth: 
  "i < length nl  
           Max {u. Pi (Suc i) ^ u dvd godel_code nl} = nl ! i"
  by(simp add: godel_code.simps godel_code'_get_nth)

lemma mod_dvd_simp: "(x mod y = (0::nat)) = (y dvd x)"
  by(simp add: dvd_def, auto)

lemma dvd_power_le: "a > Suc 0; a ^ y dvd a ^ l  y  l"
  apply(cases "y  l", simp, simp)
  apply(subgoal_tac " d. y = l + d", auto simp: power_add)
  apply(rule_tac x = "y - l" in exI, simp)
  done


lemma Pi_nonzeroE[elim]: "Pi n = 0  RR"
  using Pi_not_0[of n] by simp

lemma Pi_not_oneE[elim]: "Pi n = Suc 0  RR"
  using Pi_gr_1[of n] by simp

lemma finite_power_dvd:
  "(a::nat) > Suc 0; y  0  finite {u. a^u dvd y}"
  apply(auto simp: dvd_def simp:gr0_conv_Suc intro!:bounded_nat_set_is_finite[of _ y])
  by (metis le_less_trans mod_less mod_mult_self1_is_0 not_le Suc_lessD less_trans_Suc
      mult.right_neutral n_less_n_mult_m x_less_exp
      zero_less_Suc zero_less_mult_pos)

lemma conf_decode1: "m  n; m  k; k  n  
  Max {u. Pi m ^ u dvd Pi m ^ l * Pi n ^ st * Pi k ^ r} = l"
proof -
  let ?setx = "{u. Pi m ^ u dvd Pi m ^ l * Pi n ^ st * Pi k ^ r}"
  assume g: "m  n" "m  k" "k  n"
  show "Max ?setx = l"
  proof(rule_tac Max_eqI)
    show "finite ?setx"
      apply(rule_tac finite_power_dvd, auto)
      done
  next
    fix y
    assume h: "y  ?setx"
    have "Pi m ^ y dvd Pi m ^ l"
    proof -
      have "Pi m ^ y dvd Pi m ^ l * Pi n ^ st"
        using h g Pi_power_coprime
        by (simp add: coprime_dvd_mult_left_iff)
      thus "Pi m^y dvd Pi m^l" using g Pi_power_coprime coprime_dvd_mult_left_iff by blast
    qed
    thus "y  (l::nat)"
      apply(rule_tac a = "Pi m" in power_le_imp_le_exp)
       apply(simp_all)
      apply(rule_tac dvd_power_le, auto)
      done
  next
    show "l  ?setx" by simp
  qed
qed

lemma left_trpl_fst[simp]: "left (trpl l st r) = l"
  apply(simp add: left.simps trpl.simps lo.simps loR.simps mod_dvd_simp)
  apply(auto simp: conf_decode1)
   apply(cases "Pi 0 ^ l * Pi (Suc 0) ^ st * Pi (Suc (Suc 0)) ^ r")
    apply(auto)
  apply(erule_tac x = l in allE, auto)
  done   

lemma stat_trpl_snd[simp]: "stat (trpl l st r) = st"
  apply(simp add: stat.simps trpl.simps lo.simps 
      loR.simps mod_dvd_simp, auto)
    apply(subgoal_tac "Pi 0 ^ l * Pi (Suc 0) ^ st * Pi (Suc (Suc 0)) ^ r
               = Pi (Suc 0)^st * Pi 0 ^ l *  Pi (Suc (Suc 0)) ^ r")
     apply(simp (no_asm_simp) add: conf_decode1, simp)
   apply(cases "Pi 0 ^ l * Pi (Suc 0) ^ st * 
                                  Pi (Suc (Suc 0)) ^ r", auto)
  apply(erule_tac x = st in allE, auto)
  done

lemma rght_trpl_trd[simp]: "rght (trpl l st r) = r"
  apply(simp add: rght.simps trpl.simps lo.simps 
      loR.simps mod_dvd_simp, auto)
    apply(subgoal_tac "Pi 0 ^ l * Pi (Suc 0) ^ st * Pi (Suc (Suc 0)) ^ r
               = Pi (Suc (Suc 0))^r * Pi 0 ^ l *  Pi (Suc 0) ^ st")
     apply(simp (no_asm_simp) add: conf_decode1, simp)
   apply(cases "Pi 0 ^ l * Pi (Suc 0) ^ st * Pi (Suc (Suc 0)) ^ r",
      auto)
  apply(erule_tac x = r in allE, auto)
  done

lemma max_lor:
  "i < length nl  Max {u. loR [godel_code nl, Pi (Suc i), u]} 
                   = nl ! i"
  apply(simp add: loR.simps godel_code_get_nth mod_dvd_simp)
  done

lemma godel_decode: 
  "i < length nl  Entry (godel_code nl) i = nl ! i"
  apply(auto simp: Entry.simps lo.simps max_lor)
  apply(erule_tac x = "nl!i" in allE)
  using max_lor[of i nl] godel_finite[of i nl]
  apply(simp)
  apply(drule_tac Max_in, auto simp: loR.simps 
      godel_code.simps mod_dvd_simp)
  using godel_code_in[of i nl]
  apply(simp)
  done

lemma Four_Suc: "4 = Suc (Suc (Suc (Suc 0)))"
  by auto

declare numeral_2_eq_2[simp del]

lemma modify_tprog_fetch_even: 
  "st  length tp div 2; st > 0 
  modify_tprog tp ! (4 * (st - Suc 0) ) = 
  action_map (fst (tp ! (2 * (st - Suc 0))))"
proof(induct st arbitrary: tp, simp)
  fix tp st
  assume ind: 
    "tp. st  length tp div 2; 0 < st  
     modify_tprog tp ! (4 * (st - Suc 0)) =
               action_map (fst ((tp::instr list) ! (2 * (st - Suc 0))))"
    and h: "Suc st  length (tp::instr list) div 2" "0 < Suc st"
  thus "modify_tprog tp ! (4 * (Suc st - Suc 0)) = 
          action_map (fst (tp ! (2 * (Suc st - Suc 0))))"
  proof(cases "st = 0")
    case True thus "?thesis"
      using h by(cases tp, auto)
  next
    case False
    assume g: "st  0"
    hence " aa ab ba bb tp'. tp = (aa, ab) # (ba, bb) # tp'"
      using h by(cases tp; cases "tl tp", auto)
    from this obtain aa ab ba bb tp' where g1: 
      "tp = (aa, ab) # (ba, bb) # tp'" by blast
    hence g2: 
      "modify_tprog tp' ! (4 * (st - Suc 0)) = 
      action_map (fst ((tp'::instr list) ! (2 * (st - Suc 0))))"
      using h g by (auto intro:ind)
    thus "?thesis"
      using g1 g
      by(cases st, auto simp add: Four_Suc)
  qed
qed

lemma modify_tprog_fetch_odd: 
  "st  length tp div 2; st > 0  
       modify_tprog tp ! (Suc (Suc (4 * (st - Suc 0)))) = 
       action_map (fst (tp ! (Suc (2 * (st - Suc 0)))))"
proof(induct st arbitrary: tp, simp)
  fix tp st
  assume ind: 
    "tp. st  length tp div 2; 0 < st   
       modify_tprog tp ! Suc (Suc (4 * (st - Suc 0))) = 
          action_map (fst (tp ! Suc (2 * (st - Suc 0))))"
    and h: "Suc st  length (tp::instr list) div 2" "0 < Suc st"
  thus "modify_tprog tp ! Suc (Suc (4 * (Suc st - Suc 0))) 
     = action_map (fst (tp ! Suc (2 * (Suc st - Suc 0))))"
  proof(cases "st = 0")
    case True thus "?thesis"
      using h
      apply(cases tp, force)
      by(cases "tl tp", auto)
  next
    case False
    assume g: "st  0"
    hence " aa ab ba bb tp'. tp = (aa, ab) # (ba, bb) # tp'"
      using h
      apply(cases tp, simp, cases "tl tp", simp, simp)
      done
    from this obtain aa ab ba bb tp' where g1: 
      "tp = (aa, ab) # (ba, bb) # tp'" by blast
    hence g2: "modify_tprog tp' ! Suc (Suc (4 * (st  - Suc 0))) = 
          action_map (fst (tp' ! Suc (2 * (st - Suc 0))))"
      apply(rule_tac ind)
      using h g by auto
    thus "?thesis"
      using g1 g
      apply(cases st, simp, simp add: Four_Suc)
      done
  qed
qed    

lemma modify_tprog_fetch_action:
  "st  length tp div 2; st > 0; b = 1  b = 0  
      modify_tprog tp ! (4 * (st - Suc 0) + 2* b) =
      action_map (fst (tp ! ((2 * (st - Suc 0)) + b)))"
  apply(erule_tac disjE, auto elim: modify_tprog_fetch_odd
      modify_tprog_fetch_even)
  done 

lemma length_modify: "length (modify_tprog tp) = 2 * length tp"
  apply(induct tp, auto)
  done

declare fetch.simps[simp del]

lemma fetch_action_eq: 
  "block_map b = scan r; fetch tp st b = (nact, ns);
   st  length tp div 2  actn (code tp) st r = action_map nact"
proof(simp add: actn.simps, auto)
  let ?i = "4 * (st - Suc 0) + 2 * (r mod 2)"
  assume h: "block_map b = r mod 2" "fetch tp st b = (nact, ns)" 
    "st  length tp div 2" "0 < st"
  have "?i < length (modify_tprog tp)"
  proof -
    have "length (modify_tprog tp) = 2 * length tp"
      by(simp add: length_modify)
    thus "?thesis"
      using h
      by(auto)
  qed
  hence 
    "Entry (godel_code (modify_tprog tp))?i = 
                                   (modify_tprog tp) ! ?i"
    by(erule_tac godel_decode)
  moreover have 
    "modify_tprog tp ! ?i = 
            action_map (fst (tp ! (2 * (st - Suc 0) + r mod 2)))"
    apply(rule_tac  modify_tprog_fetch_action)
    using h
    by(auto)    
  moreover have "(fst (tp ! (2 * (st - Suc 0) + r mod 2))) = nact"
    using h
    apply(cases st, simp_all add: fetch.simps nth_of.simps)
    apply(cases b, auto simp: block_map.simps nth_of.simps fetch.simps 
        split: if_splits)
    apply(cases "r mod 2", simp, simp)
    done
  ultimately show 
    "Entry (godel_code (modify_tprog tp))
                      (4 * (st - Suc 0) + 2 * (r mod 2))
           = action_map nact" 
    by simp
qed

lemma fetch_zero_zero[simp]: "fetch tp 0 b = (nact, ns)  ns = 0"
  by(simp add: fetch.simps)

lemma modify_tprog_fetch_state:
  "st  length tp div 2; st > 0; b = 1  b = 0  
     modify_tprog tp ! Suc (4 * (st - Suc 0) + 2 * b) =
  (snd (tp ! (2 * (st - Suc 0) + b)))"
proof(induct st arbitrary: tp, simp)
  fix st tp
  assume ind: 
    "tp. st  length tp div 2; 0 < st; b = 1  b = 0  
    modify_tprog tp ! Suc (4 * (st - Suc 0) + 2 * b) =
                             snd (tp ! (2 * (st - Suc 0) + b))"
    and h:
    "Suc st  length (tp::instr list) div 2" 
    "0 < Suc st" 
    "b = 1  b = 0"
  show "modify_tprog tp ! Suc (4 * (Suc st - Suc 0) + 2 * b) =
                             snd (tp ! (2 * (Suc st - Suc 0) + b))"
  proof(cases "st = 0")
    case True
    thus "?thesis"
      using h
      apply(cases tp, force)
      apply(cases "tl tp", auto)
      done
  next
    case False
    assume g: "st  0"
    hence " aa ab ba bb tp'. tp = (aa, ab) # (ba, bb) # tp'"
      using h
      by(cases tp, force, cases "tl tp", auto)
    from this obtain aa ab ba bb tp' where g1:
      "tp = (aa, ab) # (ba, bb) # tp'" by blast
    hence g2: 
      "modify_tprog tp' ! Suc (4 * (st - Suc 0) + 2 * b) =
                              snd (tp' ! (2 * (st - Suc 0) + b))"
      apply(intro ind)
      using h g by auto
    thus "?thesis"
      using g1 g
      by(cases st;force)
  qed
qed

lemma fetch_state_eq:
  "block_map b = scan r; 
  fetch tp st b = (nact, ns);
  st  length tp div 2  newstat (code tp) st r = ns"
proof(simp add: newstat.simps, auto)
  let ?i = "Suc (4 * (st - Suc 0) + 2 * (r mod 2))"
  assume h: "block_map b = r mod 2" "fetch tp st b =
             (nact, ns)" "st  length tp div 2" "0 < st"
  have "?i < length (modify_tprog tp)"
  proof -
    have "length (modify_tprog tp) = 2 * length tp"
      by(simp add: length_modify)
    thus "?thesis"
      using h
      by(auto)
  qed
  hence "Entry (godel_code (modify_tprog tp)) (?i) = 
                                  (modify_tprog tp) ! ?i"
    by(erule_tac godel_decode)
  moreover have 
    "modify_tprog tp ! ?i =  
               (snd (tp ! (2 * (st - Suc 0) + r mod 2)))"
    apply(rule_tac  modify_tprog_fetch_state)
    using h
    by(auto)
  moreover have "(snd (tp ! (2 * (st - Suc 0) + r mod 2))) = ns"
    using h
    apply(cases st, simp)
    apply(cases b, auto simp: fetch.simps split: if_splits)
    apply(cases "(2 * (st - r mod 2) + r mod 2) = 
                       (2 * (st - 1) + r mod 2)";auto)
    by (metis diff_Suc_Suc diff_zero prod.sel(2))
  ultimately show "Entry (godel_code (modify_tprog tp)) (?i)
           = ns" 
    by simp
qed


lemma tpl_eqI[intro!]: 
  "a = a'; b = b'; c = c'  trpl a b c = trpl a' b' c'"
  by simp

lemma bl2nat_double: "bl2nat xs (Suc n) = 2 * bl2nat xs n"
proof(induct xs arbitrary: n)
  case Nil thus "?case"
    by(simp add: bl2nat.simps)
next
  case (Cons x xs) thus "?case"
  proof -
    assume ind: "n. bl2nat xs (Suc n) = 2 * bl2nat xs n "
    show "bl2nat (x # xs) (Suc n) = 2 * bl2nat (x # xs) n"
    proof(cases x)
      case Bk thus "?thesis"
        apply(simp add: bl2nat.simps)
        using ind[of "Suc n"] by simp
    next
      case Oc thus "?thesis"
        apply(simp add: bl2nat.simps)
        using ind[of "Suc n"] by simp
    qed
  qed
qed


lemma bl2wc_simps[simp]:
  "bl2wc (Oc # tl c) = Suc (bl2wc c) - bl2wc c mod 2 "
  "bl2wc (Bk # c) = 2*bl2wc (c)"
  "2 * bl2wc (tl c) = bl2wc c - bl2wc c mod 2 "
  "bl2wc [Oc] = Suc 0"
  "c  []  bl2wc (tl c) = bl2wc c div 2"
  "c  []  bl2wc [hd c] = bl2wc c mod 2"
  "c  []  bl2wc (hd c # d) = 2 * bl2wc d + bl2wc c mod 2"
  "2 * (bl2wc c div 2) = bl2wc c - bl2wc c mod 2"
  "bl2wc (Oc # list) mod 2 = Suc 0" 
  by(cases c;cases "hd c";force simp: bl2wc.simps bl2nat.simps bl2nat_double)+

declare code.simps[simp del]
declare nth_of.simps[simp del]

text ‹
  The lemma relates the one step execution of TMs with the interpreter function rec_newconf›.
›
lemma rec_t_eq_step: 
  "(λ (s, l, r). s  length tp div 2) c 
  trpl_code (step0 c tp) = 
  rec_exec rec_newconf [code tp, trpl_code c]"
proof(cases c)
  case (fields s l r) assume "case c of (s, l, r)  s  length tp div 2"
  with fields have "s  length tp div 2" by auto
  thus ?thesis unfolding fields 
  proof(cases "fetch tp s (read r)",
      simp add: newconf.simps trpl_code.simps step.simps)
    fix a b ca aa ba
    assume h: "(a::nat)  length tp div 2" 
      "fetch tp a (read ca) = (aa, ba)"
    moreover hence "actn (code tp) a (bl2wc ca) = action_map aa"
      apply(rule_tac b = "read ca" 
          in fetch_action_eq, auto)
      apply(cases "hd ca";cases ca;force)
      done
    moreover from h have "(newstat (code tp) a (bl2wc ca)) = ba"
      apply(rule_tac b = "read ca" 
          in fetch_state_eq, auto split: list.splits)
      apply(cases "hd ca";cases ca;force)
      done
    ultimately show 
      "trpl_code (ba, update aa (b, ca)) =
          trpl (newleft (bl2wc b) (bl2wc ca) (actn (code tp) a (bl2wc ca))) 
    (newstat (code tp) a (bl2wc ca)) (newrght (bl2wc b) (bl2wc ca) (actn (code tp) a (bl2wc ca)))"
      apply(cases aa)
          apply(auto simp: trpl_code.simps 
          newleft.simps newrght.simps split: action.splits)
      done
  qed
qed

lemma bl2nat_simps[simp]: "bl2nat (Oc # Ocx) 0 = (2 * 2 ^ x - Suc 0)"
  "bl2nat (Bkx) n = 0"
  by(induct x;force simp: bl2nat.simps bl2nat_double exp_ind)+

lemma bl2nat_exp_zero[simp]: "bl2nat (Ocy) 0 = 2^y - Suc 0"
proof(induct y)
  case (Suc y)
  then show ?case by(cases "(2::nat)^y", auto)
qed (auto simp: bl2nat.simps bl2nat_double)

lemma bl2nat_cons_bk: "bl2nat (ks @ [Bk]) 0 = bl2nat ks 0"
proof(induct ks)
  case (Cons a ks)
  then show ?case by (cases a, auto simp: bl2nat.simps bl2nat_double)
qed (auto simp: bl2nat.simps)

lemma bl2nat_cons_oc:
  "bl2nat (ks @ [Oc]) 0 =  bl2nat ks 0 + 2 ^ length ks"
proof(induct ks)
  case (Cons a ks)
  then show ?case 
    by(cases a, auto simp: bl2nat.simps bl2nat_double)
qed (auto simp: bl2nat.simps)

lemma bl2nat_append: 
  "bl2nat (xs @ ys) 0 = bl2nat xs 0 + bl2nat ys (length xs) "
proof(induct "length xs" arbitrary: xs ys, simp add: bl2nat.simps)
  fix x xs ys
  assume ind: 
    "xs ys. x = length xs  
             bl2nat (xs @ ys) 0 = bl2nat xs 0 + bl2nat ys (length xs)"
    and h: "Suc x = length (xs::cell list)"
  have " ks k. xs = ks @ [k]" 
    apply(rule_tac x = "butlast xs" in exI,
        rule_tac x = "last xs" in exI)
    using h
    apply(cases xs, auto)
    done
  from this obtain ks k where "xs = ks @ [k]" by blast
  moreover hence 
    "bl2nat (ks @ (k # ys)) 0 = bl2nat ks 0 +
                               bl2nat (k # ys) (length ks)"
    apply(rule_tac ind) using h by simp
  ultimately show "bl2nat (xs @ ys) 0 = 
                  bl2nat xs 0 + bl2nat ys (length xs)"
    apply(cases k, simp_all add: bl2nat.simps)
     apply(simp_all only: bl2nat_cons_bk bl2nat_cons_oc)
    done
qed

lemma trpl_code_simp[simp]:
  "trpl_code (steps0 (Suc 0, Bkl, <lm>) tp 0) = 
    rec_exec rec_conf [code tp, bl2wc (<lm>), 0]"
  apply(simp add: steps.simps rec_exec.simps conf_lemma  conf.simps 
      inpt.simps trpl_code.simps bl2wc.simps)
  done

text ‹
  The following lemma relates the multi-step interpreter function rec_conf›
  with the multi-step execution of TMs.
›
lemma state_in_range_step
  : "a  length A div 2; step0 (a, b, c) A = (st, l, r); tm_wf (A,0)
   st  length A div 2"
  apply(simp add: step.simps fetch.simps tm_wf.simps 
      split: if_splits list.splits)
   apply(case_tac [!] a, auto simp: list_all_length 
      fetch.simps nth_of.simps)
   apply(erule_tac x = "A ! (2*nat) " in ballE, auto)
  apply(cases "hd c", auto simp: fetch.simps nth_of.simps)
   apply(erule_tac x = "A !(2 * nat)" in ballE, auto)
  apply(erule_tac x = "A !Suc (2 * nat)" in ballE, auto)
  done

lemma state_in_range: "steps0 (Suc 0, tp) A stp = (st, l, r); tm_wf (A, 0)
   st  length A div 2"
proof(induct stp arbitrary: st l r)
  case (Suc stp st l r)
  from Suc.prems show ?case
  proof(simp add: step_red, cases "(steps0 (Suc 0, tp) A stp)", simp)
    fix a b c 
    assume h3: "step0 (a, b, c) A = (st, l, r)"
      and h4: "steps0 (Suc 0, tp) A stp = (a, b, c)"
    have "a  length A div 2" using Suc.prems h4 by (auto intro: Suc.hyps)
    thus "?thesis" using h3 Suc.prems by (auto elim: state_in_range_step)
  qed
qed(auto simp: tm_wf.simps steps.simps)

lemma rec_t_eq_steps:
  "tm_wf (tp,0) 
  trpl_code (steps0 (Suc 0, Bkl, <lm>) tp stp) = 
  rec_exec rec_conf [code tp, bl2wc (<lm>), stp]"
proof(induct stp)
  case 0 thus "?case" by(simp)
next
  case (Suc n) thus "?case"
  proof -
    assume ind: 
      "tm_wf (tp,0)  trpl_code (steps0 (Suc 0, Bk l, <lm>) tp n) 
      = rec_exec rec_conf [code tp, bl2wc (<lm>), n]"
      and h: "tm_wf (tp, 0)"
    show 
      "trpl_code (steps0 (Suc 0, Bk l, <lm>) tp (Suc n)) =
      rec_exec rec_conf [code tp, bl2wc (<lm>), Suc n]"
    proof(cases "steps0 (Suc 0, Bk l, <lm>) tp  n", 
        simp only: step_red conf_lemma conf.simps)
      fix a b c
      assume g: "steps0 (Suc 0, Bk l, <lm>) tp n = (a, b, c) "
      hence "conf (code tp) (bl2wc (<lm>)) n= trpl_code (a, b, c)"
        using ind h
        apply(simp add: conf_lemma)
        done
      moreover hence 
        "trpl_code (step0 (a, b, c) tp) = 
        rec_exec rec_newconf [code tp, trpl_code (a, b, c)]"
        apply(rule_tac rec_t_eq_step)
        using h g
        apply(simp add: state_in_range)
        done
      ultimately show 
        "trpl_code (step0 (a, b, c) tp) =
            newconf (code tp) (conf (code tp) (bl2wc (<lm>)) n)"
        by(simp)
    qed
  qed
qed

lemma bl2wc_Bk_0[simp]: "bl2wc (Bk m) = 0"
  apply(induct m)
   apply(simp, simp)
  done

lemma bl2wc_Oc_then_Bk[simp]: "bl2wc (Oc rs@Bk n) = bl2wc (Oc rs)"
  apply(induct rs, simp, 
      simp add: bl2wc.simps bl2nat.simps bl2nat_double)
  done

lemma lg_power: "x > Suc 0  lg (x ^ rs) x = rs"
proof(simp add: lg.simps, auto)
  fix xa
  assume h: "Suc 0 < x"
  show "Max {ya. ya  x ^ rs  lgR [x ^ rs, x, ya]} = rs"
    apply(rule_tac Max_eqI, simp_all add: lgR.simps)
     apply(simp add: h)
    using x_less_exp[of x rs] h
    apply(simp)
    done
next
  assume "¬ Suc 0 < x ^ rs" "Suc 0 < x" 
  thus "rs = 0"
    apply(cases "x ^ rs", simp, simp)
    done
next
  assume "Suc 0 < x" "xa. ¬ lgR [x ^ rs, x, xa]"
  thus "rs = 0"
    apply(simp only:lgR.simps)
    apply(erule_tac x = rs in allE, simp)
    done
qed    

text ‹
  The following lemma relates execution of TMs with 
  the multi-step interpreter function rec_nonstop›. Note,
  rec_nonstop› is constructed using rec_conf›.
›

declare tm_wf.simps[simp del]

lemma nonstop_t_eq: 
  "steps0 (Suc 0, Bkl, <lm>) tp stp = (0, Bk m, Oc rs @ Bk n); 
   tm_wf (tp, 0); 
  rs > 0 
   rec_exec rec_nonstop [code tp, bl2wc (<lm>), stp] = 0"
proof(simp add: nonstop_lemma nonstop.simps )
  assume h: "steps0 (Suc 0, Bkl, <lm>) tp stp = (0, Bk m, Oc rs @ Bk n)"
    and tc_t: "tm_wf (tp, 0)" "rs > 0"
  have g: "rec_exec rec_conf [code tp,  bl2wc (<lm>), stp] =
                                        trpl_code (0, Bk m, Oc rs@Bk n)"
    using rec_t_eq_steps[of tp l lm stp] tc_t h
    by(simp)
  thus "¬ NSTD (conf (code tp) (bl2wc (<lm>)) stp)" 
  proof(auto simp: NSTD.simps)
    show "stat (conf (code tp) (bl2wc (<lm>)) stp) = 0"
      using g
      by(auto simp: conf_lemma trpl_code.simps)
  next
    show "left (conf (code tp) (bl2wc (<lm>)) stp) = 0"
      using g
      by(simp add: conf_lemma trpl_code.simps)
  next
    show "rght (conf (code tp) (bl2wc (<lm>)) stp) = 
           2 ^ lg (Suc (rght (conf (code tp) (bl2wc (<lm>)) stp))) 2 - Suc 0"
      using g h
    proof(simp add: conf_lemma trpl_code.simps)
      have "2 ^ lg (Suc (bl2wc (Oc rs))) 2 = Suc (bl2wc (Oc rs))"
        apply(simp add: bl2wc.simps lg_power)
        done
      thus "bl2wc (Oc rs) = 2 ^ lg (Suc (bl2wc (Oc rs))) 2 - Suc 0"
        apply(simp)
        done
    qed
  next
    show "0 < rght (conf (code tp) (bl2wc (<lm>)) stp)"
      using g h tc_t
      apply(simp add: conf_lemma trpl_code.simps bl2wc.simps
          bl2nat.simps)
      apply(cases rs, simp, simp add: bl2nat.simps)
      done
  qed
qed

lemma actn_0_is_4[simp]: "actn m 0 r = 4"
  by(simp add: actn.simps)

lemma newstat_0_0[simp]: "newstat m 0 r = 0"
  by(simp add: newstat.simps)

declare step_red[simp del]

lemma halt_least_step: 
  "steps0 (Suc 0, Bkl, <lm>) tp stp = 
       (0, Bk m, Ocrs @ Bkn); 
    tm_wf (tp, 0); 
    0<rs 
     stp. (nonstop (code tp) (bl2wc (<lm>)) stp = 0 
       ( stp'. nonstop (code tp) (bl2wc (<lm>)) stp' = 0  stp  stp'))"
proof(induct stp)
  case 0
  then show ?case by (simp add: steps.simps(1))
next
  case (Suc stp)
  hence ind: 
    "steps0 (Suc 0, Bk l, <lm>) tp stp = (0, Bk m, Oc rs @ Bk n)  
    stp. nonstop (code tp) (bl2wc (<lm>)) stp = 0  
          (stp'. nonstop (code tp) (bl2wc (<lm>)) stp' = 0  stp  stp')"
    and h: 
    "steps0 (Suc 0, Bk l, <lm>) tp (Suc stp) = (0, Bk m, Oc rs @ Bk n)"
    "tm_wf (tp, 0::nat)" 
    "0 < rs" by simp+
  {
    fix a b c nat
    assume "steps0 (Suc 0, Bk l, <lm>) tp stp = (a, b, c)"
      "a = Suc nat"
    hence "stp. nonstop (code tp) (bl2wc (<lm>)) stp = 0  
      (stp'. nonstop (code tp) (bl2wc (<lm>)) stp' = 0  stp  stp')"
      using h
      apply(rule_tac x = "Suc stp" in exI, auto)
       apply(drule_tac  nonstop_t_eq, simp_all add: nonstop_lemma)
    proof -
      fix stp'
      assume g:"steps0 (Suc 0, Bk l, <lm>) tp stp = (Suc nat, b, c)" 
        "nonstop (code tp) (bl2wc (<lm>)) stp' = 0"
      thus  "Suc stp  stp'"
      proof(cases "Suc stp  stp'", simp, simp)
        assume "¬ Suc stp  stp'"
        hence "stp'  stp" by simp
        hence "¬ is_final (steps0 (Suc 0, Bk l, <lm>) tp stp')"
          using g
          apply(cases "steps0 (Suc 0, Bk l, <lm>) tp stp'",auto, simp)
          apply(subgoal_tac " n. stp = stp' + n", auto)
           apply(cases "fst (steps0 (Suc 0, Bk  l, <lm>) tp stp')", simp_all add: steps.simps)
          apply(rule_tac x = "stp - stp'"  in exI, simp)
          done         
        hence "nonstop (code tp) (bl2wc (<lm>)) stp' = 1"
        proof(cases "steps0 (Suc 0, Bk l, <lm>) tp stp'",
            simp add: nonstop.simps)
          fix a b c
          assume k: 
            "0 < a" "steps0 (Suc 0, Bk l, <lm>) tp stp' = (a, b, c)"
          thus " NSTD (conf (code tp) (bl2wc (<lm>)) stp')"
            using rec_t_eq_steps[of tp l lm stp'] h
          proof(simp add: conf_lemma) 
            assume "trpl_code (a, b, c) = conf (code tp) (bl2wc (<lm>)) stp'"
            moreover have "NSTD (trpl_code (a, b, c))"
              using k
              apply(auto simp: trpl_code.simps NSTD.simps)
              done
            ultimately show "NSTD (conf (code tp) (bl2wc (<lm>)) stp')" by simp
          qed
        qed
        thus "False" using g by simp
      qed qed
    }
    note [intro] = this
    from h show 
      "stp. nonstop (code tp) (bl2wc (<lm>)) stp = 0 
     (stp'. nonstop (code tp) (bl2wc (<lm>)) stp' = 0  stp  stp')"
      by(simp add: step_red, 
          cases "steps0 (Suc 0, Bk l, <lm>) tp stp", simp, 
          cases "fst (steps0 (Suc 0, Bk l, <lm>) tp stp)",
          auto simp add: nonstop_t_eq intro:ind dest:nonstop_t_eq)
  qed    

lemma conf_trpl_ex: " p q r. conf m (bl2wc (<lm>)) stp = trpl p q r"
  apply(induct stp, auto simp: conf.simps inpt.simps trpl.simps 
      newconf.simps)
  apply(rule_tac x = 0 in exI, rule_tac x = 1 in exI, 
      rule_tac x = "bl2wc (<lm>)" in exI)
  apply(simp)
  done

lemma nonstop_rgt_ex: 
  "nonstop m (bl2wc (<lm>)) stpa = 0   r. conf m (bl2wc (<lm>)) stpa = trpl 0 0 r"
  apply(auto simp: nonstop.simps NSTD.simps split: if_splits)
  using conf_trpl_ex[of m lm stpa]
  apply(auto)
  done

lemma max_divisors: "x > Suc 0  Max {u. x ^ u dvd x ^ r} = r"
proof(rule_tac Max_eqI)
  assume "x > Suc 0"
  thus "finite {u. x ^ u dvd x ^ r}"
    apply(rule_tac finite_power_dvd, auto)
    done
next
  fix y 
  assume "Suc 0 < x" "y  {u. x ^ u dvd x ^ r}"
  thus "y  r"
    apply(cases "y r", simp)
    apply(subgoal_tac " d. y = r + d")
     apply(auto simp: power_add)
    apply(rule_tac x = "y - r" in exI, simp)
    done
next
  show "r  {u. x ^ u dvd x ^ r}" by simp
qed  

lemma lo_power:
  assumes "x > Suc 0" shows "lo (x ^ r) x = r"
proof -
  have "¬ Suc 0 < x ^ r  r = 0" using assms
    by (metis Suc_lessD Suc_lessI nat_power_eq_Suc_0_iff zero_less_power)
  moreover have "xa. ¬ x ^ xa dvd x ^ r  r = 0"
    using dvd_refl assms by(cases "x^r";blast)
  ultimately show ?thesis using assms
    by(auto simp: lo.simps loR.simps mod_dvd_simp elim:max_divisors)
qed

lemma lo_rgt: "lo (trpl 0 0 r) (Pi 2) = r"
  apply(simp add: trpl.simps lo_power)
  done

lemma conf_keep: 
  "conf m lm stp = trpl 0 0 r  
  conf m lm (stp + n) = trpl 0 0 r"
  apply(induct n)
   apply(auto simp: conf.simps  newconf.simps newleft.simps 
      newrght.simps rght.simps lo_rgt)
  done

lemma halt_state_keep_steps_add:
  "nonstop m (bl2wc (<lm>)) stpa = 0  
  conf m (bl2wc (<lm>)) stpa = conf m (bl2wc (<lm>)) (stpa + n)"
  apply(drule_tac nonstop_rgt_ex, auto simp: conf_keep)
  done

lemma halt_state_keep: 
  "nonstop m (bl2wc (<lm>)) stpa = 0; nonstop m (bl2wc (<lm>)) stpb = 0 
  conf m (bl2wc (<lm>)) stpa = conf m (bl2wc (<lm>)) stpb"
  apply(cases "stpa > stpb")
  using halt_state_keep_steps_add[of m lm stpb "stpa - stpb"] 
   apply simp
  using halt_state_keep_steps_add[of m lm stpa "stpb - stpa"]
  apply(simp)
  done

text ‹
  The correntess of rec_F› which relates the interpreter function rec_F› with the
  execution of of TMs.
›

lemma terminate_halt: 
  "steps0 (Suc 0, Bkl, <lm>) tp stp = (0, Bkm, Ocrs@Bkn); 
    tm_wf (tp,0); 0<rs  terminate rec_halt [code tp, (bl2wc (<lm>))]"
  by(frule_tac halt_least_step;force simp:nonstop_lemma intro:terminate_halt_lemma)

lemma terminate_F: 
  "steps0 (Suc 0, Bkl, <lm>) tp stp = (0, Bkm, Ocrs@Bkn); 
    tm_wf (tp,0); 0<rs  terminate rec_F [code tp, (bl2wc (<lm>))]"
  apply(drule_tac terminate_halt, simp_all)
  apply(erule_tac terminate_F_lemma)
  done

lemma F_correct: 
  "steps0 (Suc 0, Bkl, <lm>) tp stp = (0, Bkm, Ocrs@Bkn); 
    tm_wf (tp,0); 0<rs
    rec_exec rec_F [code tp, (bl2wc (<lm>))] = (rs - Suc 0)"
  apply(frule_tac halt_least_step, auto)
  apply(frule_tac  nonstop_t_eq, auto simp: nonstop_lemma)
  using rec_t_eq_steps[of tp l lm stp]
  apply(simp add: conf_lemma)
proof -
  fix stpa
  assume h: 
    "nonstop (code tp) (bl2wc (<lm>)) stpa = 0" 
    "stp'. nonstop (code tp) (bl2wc (<lm>)) stp' = 0  stpa  stp'" 
    "nonstop (code tp) (bl2wc (<lm>)) stp = 0" 
    "trpl_code (0, Bk m, Oc rs @ Bk n) = conf (code tp) (bl2wc (<lm>)) stp"
    "steps0 (Suc 0, Bk l, <lm>) tp stp = (0, Bk m, Oc rs @ Bk n)"
  hence g1: "conf (code tp) (bl2wc (<lm>)) stpa = trpl_code (0, Bk m, Oc rs @ Bkn)"
    using halt_state_keep[of "code tp" lm stpa stp]
    by(simp)
  moreover have g2:
    "rec_exec rec_halt [code tp, (bl2wc (<lm>))] = stpa"
    using h
    by(auto simp: rec_exec.simps rec_halt_def nonstop_lemma intro!: Least_equality)
  show  
    "rec_exec rec_F [code tp, (bl2wc (<lm>))] = (rs - Suc 0)"
  proof -
    have 
      "valu (rght (conf (code tp) (bl2wc (<lm>)) stpa)) = rs - Suc 0" 
      using g1 
      apply(simp add: valu.simps trpl_code.simps 
          bl2wc.simps  bl2nat_append lg_power)
      done
    thus "?thesis" 
      by(simp add: rec_exec.simps F_lemma g2)
  qed
qed

end

Theory UTM

(* Title: thys/UTM.thy
   Author: Jian Xu, Xingyuan Zhang, and Christian Urban
   Modifications: Sebastiaan Joosten
*)

chapter ‹Construction of a Universal Turing Machine›

theory UTM
  imports Recursive Abacus UF HOL.GCD Turing_Hoare
begin

section ‹Wang coding of input arguments›

text ‹
  The direct compilation of the universal function rec_F› can
  not give us UTM, because rec_F› is of arity 2, where the
  first argument represents the Godel coding of the TM being simulated
  and the second argument represents the right number (in Wang's
  coding) of the TM tape.  (Notice, left number is always 0›
  at the very beginning). However, UTM needs to simulate the execution
  of any TM which may very well take many input arguments. Therefore,
  a initialization TM needs to run before the TM compiled from rec_F›, and the sequential composition of these two TMs will give
  rise to the UTM we are seeking. The purpose of this initialization
  TM is to transform the multiple input arguments of the TM being
  simulated into Wang's coding, so that it can be consumed by the TM
  compiled from rec_F› as the second argument.

  However, this initialization TM (named t_wcode›) can not be
  constructed by compiling from any recursive function, because every
  recursive function takes a fixed number of input arguments, while
  t_wcode› needs to take varying number of arguments and
  tranform them into Wang's coding. Therefore, this section give a
  direct construction of t_wcode› with just some parts being
  obtained from recursive functions.

\newlength{\basewidth}
\settowidth{\basewidth}{xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx}
\newlength{\baseheight}
\settoheight{\baseheight}{$B:R$}
\newcommand{\vsep}{5\baseheight}

The TM used to generate the Wang's code of input arguments is divided into three TMs
 executed sequentially, namely $prepare$, $mainwork$ and $adjust$.
 According to the
 convention, the start state of ever TM is fixed to state $1$ while the final state is
 fixed to $0$.

The input and output of $prepare$ are illustrated respectively by Figure
\ref{prepare_input} and \ref{prepare_output}.


\begin{figure}[h!]
\centering
\scalebox{1.2}{
\begin{tikzpicture}
  [tbox/.style = {draw, thick, inner sep = 5pt}]
  \node (0) {};
  \node (1) [tbox, text height = 3.5pt, right = -0.9pt of 0] {$m$};
  \node (2) [tbox, right = -0.9pt of 1] {$0$};
  \node (3) [tbox, right = -0.9pt of 2] {$a_1$};
  \node (4) [tbox, right = -0.9pt of 3] {$0$};
  \node (5) [tbox, right = -0.9pt of 4] {$a_2$};
  \node (6) [right = -0.9pt of 5] {\ldots \ldots};
  \node (7) [tbox, right = -0.9pt of 6] {$a_n$};
  \draw [->, >=latex, thick] (1)+(0, -4\baseheight) -- (1);
\end{tikzpicture}}
\caption{The input of TM $prepare$} \label{prepare_input}
\end{figure}

\begin{figure}[h!]
\centering
\scalebox{1.2}{
\begin{tikzpicture}
  \node (0) {};
  \node (1) [draw, text height = 3.5pt, right = -0.9pt of 0, thick, inner sep = 5pt] {$m$};
  \node (2) [draw, right = -0.9pt of 1, thick, inner sep = 5pt] {$0$};
  \node (3) [draw, right = -0.9pt of 2, thick, inner sep = 5pt] {$0$};
  \node (4) [draw, right = -0.9pt of 3, thick, inner sep = 5pt] {$a_1$};
  \node (5) [draw, right = -0.9pt of 4, thick, inner sep = 5pt] {$0$};
  \node (6) [draw, right = -0.9pt of 5, thick, inner sep = 5pt] {$a_2$};
  \node (7) [right = -0.9pt of 6] {\ldots \ldots};
  \node (8) [draw, right = -0.9pt of 7, thick, inner sep = 5pt] {$a_n$};
  \node (9) [draw, right = -0.9pt of 8, thick, inner sep = 5pt] {$0$};
  \node (10) [draw, right = -0.9pt of 9, thick, inner sep = 5pt] {$0$};
  \node (11) [draw, right = -0.9pt of 10, thick, inner sep = 5pt] {$1$};
  \draw [->, >=latex, thick] (10)+(0, -4\baseheight) -- (10);
\end{tikzpicture}}
\caption{The output of TM $prepare$} \label{prepare_output}
\end{figure}

As shown in Figure \ref{prepare_input}, the input of $prepare$ is the
same as the the input of UTM, where $m$ is the Godel coding of the TM
being interpreted and $a_1$ through $a_n$ are the $n$ input arguments
of the TM under interpretation. The purpose of $purpose$ is to
transform this initial tape layout to the one shown in Figure
\ref{prepare_output}, which is convenient for the generation of Wang's
codding of $a_1, \ldots, a_n$. The coding procedure starts from $a_n$
and ends after $a_1$ is encoded. The coding result is stored in an
accumulator at the end of the tape (initially represented by the $1$
two blanks right to $a_n$ in Figure \ref{prepare_output}). In Figure
\ref{prepare_output}, arguments $a_1, \ldots, a_n$ are separated by
two blanks on both ends with the rest so that movement conditions can
be implemented conveniently in subsequent TMs, because, by convention,
two consecutive blanks are usually used to signal the end or start of
a large chunk of data. The diagram of $prepare$ is given in Figure
\ref{prepare_diag}.


\begin{figure}[h!]
\centering
\scalebox{0.9}{
\begin{tikzpicture}
     \node[circle,draw] (1) {$1$};
     \node[circle,draw] (2) at ($(1)+(0.3\basewidth, 0)$) {$2$};
     \node[circle,draw] (3) at ($(2)+(0.3\basewidth, 0)$) {$3$};
     \node[circle,draw] (4) at ($(3)+(0.3\basewidth, 0)$) {$4$};
     \node[circle,draw] (5) at ($(4)+(0.3\basewidth, 0)$) {$5$};
     \node[circle,draw] (6) at ($(5)+(0.3\basewidth, 0)$) {$6$};
     \node[circle,draw] (7) at ($(6)+(0.3\basewidth, 0)$) {$7$};
     \node[circle,draw] (8) at ($(7)+(0.3\basewidth, 0)$) {$0$};


     \draw [->, >=latex] (1) edge [loop above] node[above] {$S_1:L$} (1)
     ;
     \draw [->, >=latex] (1) -- node[above] {$S_0:S_1$} (2)
     ;
     \draw [->, >=latex] (2) edge [loop above] node[above] {$S_1:R$} (2)
     ;
     \draw [->, >=latex] (2) -- node[above] {$S_0:L$} (3)
     ;
     \draw [->, >=latex] (3) edge[loop above] node[above] {$S_1:S_0$} (3)
     ;
     \draw [->, >=latex] (3) -- node[above] {$S_0:R$} (4)
     ;
     \draw [->, >=latex] (4) edge[loop above] node[above] {$S_0:R$} (4)
     ;
     \draw [->, >=latex] (4) -- node[above] {$S_0:R$} (5)
     ;
     \draw [->, >=latex] (5) edge[loop above] node[above] {$S_1:R$} (5)
     ;
     \draw [->, >=latex] (5) -- node[above] {$S_0:R$} (6)
     ;
     \draw [->, >=latex] (6) edge[bend left = 50] node[below] {$S_1:R$} (5)
     ;
     \draw [->, >=latex] (6) -- node[above] {$S_0:R$} (7)
     ;
     \draw [->, >=latex] (7) edge[loop above] node[above] {$S_0:S_1$} (7)
     ;
     \draw [->, >=latex] (7) -- node[above] {$S_1:L$} (8)
     ;
 \end{tikzpicture}}
\caption{The diagram of TM $prepare$} \label{prepare_diag}
\end{figure}

The purpose of TM $mainwork$ is to compute the Wang's encoding of $a_1, \ldots, a_n$. Every bit of $a_1, \ldots, a_n$, including the separating bits, is processed from left to right.
In order to detect the termination condition when the left most bit of $a_1$ is reached,
TM $mainwork$ needs to look ahead and consider three different situations at the start of
every iteration:
\begin{enumerate}
    \item The TM configuration for the first situation is shown in Figure \ref{mainwork_case_one_input},
        where the accumulator is stored in $r$, both of the next two bits
        to be encoded are $1$. The configuration at the end of the iteration
        is shown in Figure \ref{mainwork_case_one_output}, where the first 1-bit has been
        encoded and cleared. Notice that the accumulator has been changed to
        $(r+1) \times 2$ to reflect the encoded bit.
    \item The TM configuration for the second situation is shown in Figure
        \ref{mainwork_case_two_input},
        where the accumulator is stored in $r$, the next two bits
        to be encoded are $1$ and $0$. After the first
        $1$-bit was encoded and cleared, the second $0$-bit is difficult to detect
        and process. To solve this problem, these two consecutive bits are
        encoded in one iteration.  In this situation, only the first $1$-bit needs
        to be cleared since the second one is cleared by definition.
        The configuration at the end of the iteration
        is shown in Figure \ref{mainwork_case_two_output}.
        Notice that the accumulator has been changed to
        $(r+1) \times 4$ to reflect the two encoded bits.
    \item The third situation corresponds to the case when the last bit of $a_1$ is reached.
        The TM configurations at the start and end of the iteration are shown in
        Figure \ref{mainwork_case_three_input} and \ref{mainwork_case_three_output}
        respectively. For this situation, only the read write head needs to be moved to
        the left to prepare a initial configuration for TM $adjust$ to start with.
\end{enumerate}
The diagram of $mainwork$ is given in Figure \ref{mainwork_diag}. The two rectangular nodes
labeled with $2 \times x$ and $4 \times x$ are two TMs compiling from recursive functions
so that we do not have to design and verify two quite complicated TMs.


\begin{figure}[h!]
\centering
\scalebox{1.2}{
\begin{tikzpicture}
  \node (0) {};
  \node (1) [draw, text height = 3.9pt, right = -0.9pt of 0, thick, inner sep = 5pt] {$m$};
  \node (2) [draw, right = -0.9pt of 1, thick, inner sep = 5pt] {$0$};
  \node (3) [draw, right = -0.9pt of 2, thick, inner sep = 5pt] {$0$};
  \node (4) [draw, right = -0.9pt of 3, thick, inner sep = 5pt] {$a_1$};
  \node (5) [draw, right = -0.9pt of 4, thick, inner sep = 5pt] {$0$};
  \node (6) [draw, right = -0.9pt of 5, thick, inner sep = 5pt] {$a_2$};
  \node (7) [right = -0.9pt of 6] {\ldots \ldots};
  \node (8) [draw, right = -0.9pt of 7, thick, inner sep = 5pt] {$a_i$};
  \node (9) [draw, right = -0.9pt of 8, thick, inner sep = 5pt] {$1$};
  \node (10) [draw, right = -0.9pt of 9, thick, inner sep = 5pt] {$1$};
  \node (11) [draw, right = -0.9pt of 10, thick, inner sep = 5pt] {$0$};
  \node (12) [right = -0.9pt of 11] {\ldots \ldots};
  \node (13) [draw, right = -0.9pt of 12, thick, inner sep = 5pt] {$0$};
  \node (14) [draw, text height = 3.9pt, right = -0.9pt of 13, thick, inner sep = 5pt] {$r$};
  \draw [->, >=latex, thick] (13)+(0, -4\baseheight) -- (13);
\end{tikzpicture}}
\caption{The first situation for TM $mainwork$ to consider} \label{mainwork_case_one_input}
\end{figure}


\begin{figure}[h!]
\centering
\scalebox{1.2}{
\begin{tikzpicture}
  \node (0) {};
  \node (1) [draw, text height = 3.9pt, right = -0.9pt of 0, thick, inner sep = 5pt] {$m$};
  \node (2) [draw, right = -0.9pt of 1, thick, inner sep = 5pt] {$0$};
  \node (3) [draw, right = -0.9pt of 2, thick, inner sep = 5pt] {$0$};
  \node (4) [draw, right = -0.9pt of 3, thick, inner sep = 5pt] {$a_1$};
  \node (5) [draw, right = -0.9pt of 4, thick, inner sep = 5pt] {$0$};
  \node (6) [draw, right = -0.9pt of 5, thick, inner sep = 5pt] {$a_2$};
  \node (7) [right = -0.9pt of 6] {\ldots \ldots};
  \node (8) [draw, right = -0.9pt of 7, thick, inner sep = 5pt] {$a_i$};
  \node (9) [draw, right = -0.9pt of 8, thick, inner sep = 5pt] {$1$};
  \node (10) [draw, right = -0.9pt of 9, thick, inner sep = 5pt] {$0$};
  \node (11) [draw, right = -0.9pt of 10, thick, inner sep = 5pt] {$0$};
  \node (12) [right = -0.9pt of 11] {\ldots \ldots};
  \node (13) [draw, right = -0.9pt of 12, thick, inner sep = 5pt] {$0$};
  \node (14) [draw, text height = 2.7pt, right = -0.9pt of 13, thick, inner sep = 5pt] {$(r+1) \times 2$};
  \draw [->, >=latex, thick] (13)+(0, -4\baseheight) -- (13);
\end{tikzpicture}}
\caption{The output for the first case of TM $mainwork$'s processing}
\label{mainwork_case_one_output}
\end{figure}

\begin{figure}[h!]
\centering
\scalebox{1.2}{
\begin{tikzpicture}
  \node (0) {};
  \node (1) [draw, text height = 3.9pt, right = -0.9pt of 0, thick, inner sep = 5pt] {$m$};
  \node (2) [draw, right = -0.9pt of 1, thick, inner sep = 5pt] {$0$};
  \node (3) [draw, right = -0.9pt of 2, thick, inner sep = 5pt] {$0$};
  \node (4) [draw, right = -0.9pt of 3, thick, inner sep = 5pt] {$a_1$};
  \node (5) [draw, right = -0.9pt of 4, thick, inner sep = 5pt] {$0$};
  \node (6) [draw, right = -0.9pt of 5, thick, inner sep = 5pt] {$a_2$};
  \node (7) [right = -0.9pt of 6] {\ldots \ldots};
  \node (8) [draw, right = -0.9pt of 7, thick, inner sep = 5pt] {$a_i$};
  \node (9) [draw, right = -0.9pt of 8, thick, inner sep = 5pt] {$1$};
  \node (10) [draw, right = -0.9pt of 9, thick, inner sep = 5pt] {$0$};
  \node (11) [draw, right = -0.9pt of 10, thick, inner sep = 5pt] {$1$};
  \node (12) [draw, right = -0.9pt of 11, thick, inner sep = 5pt] {$0$};
  \node (13) [right = -0.9pt of 12] {\ldots \ldots};
  \node (14) [draw, right = -0.9pt of 13, thick, inner sep = 5pt] {$0$};
  \node (15) [draw, text height = 3.9pt, right = -0.9pt of 14, thick, inner sep = 5pt] {$r$};
  \draw [->, >=latex, thick] (14)+(0, -4\baseheight) -- (14);
\end{tikzpicture}}
\caption{The second situation for TM $mainwork$ to consider} \label{mainwork_case_two_input}
\end{figure}

\begin{figure}[h!]
\centering
\scalebox{1.2}{
\begin{tikzpicture}
  \node (0) {};
  \node (1) [draw, text height = 3.9pt, right = -0.9pt of 0, thick, inner sep = 5pt] {$m$};
  \node (2) [draw, right = -0.9pt of 1, thick, inner sep = 5pt] {$0$};
  \node (3) [draw, right = -0.9pt of 2, thick, inner sep = 5pt] {$0$};
  \node (4) [draw, right = -0.9pt of 3, thick, inner sep = 5pt] {$a_1$};
  \node (5) [draw, right = -0.9pt of 4, thick, inner sep = 5pt] {$0$};
  \node (6) [draw, right = -0.9pt of 5, thick, inner sep = 5pt] {$a_2$};
  \node (7) [right = -0.9pt of 6] {\ldots \ldots};
  \node (8) [draw, right = -0.9pt of 7, thick, inner sep = 5pt] {$a_i$};
  \node (9) [draw, right = -0.9pt of 8, thick, inner sep = 5pt] {$1$};
  \node (10) [draw, right = -0.9pt of 9, thick, inner sep = 5pt] {$0$};
  \node (11) [draw, right = -0.9pt of 10, thick, inner sep = 5pt] {$0$};
  \node (12) [draw, right = -0.9pt of 11, thick, inner sep = 5pt] {$0$};
  \node (13) [right = -0.9pt of 12] {\ldots \ldots};
  \node (14) [draw, right = -0.9pt of 13, thick, inner sep = 5pt] {$0$};
  \node (15) [draw, text height = 2.7pt, right = -0.9pt of 14, thick, inner sep = 5pt] {$(r+1) \times 4$};
  \draw [->, >=latex, thick] (14)+(0, -4\baseheight) -- (14);
\end{tikzpicture}}
\caption{The output for the second case of TM $mainwork$'s processing}
\label{mainwork_case_two_output}
\end{figure}

\begin{figure}[h!]
\centering
\scalebox{1.2}{
\begin{tikzpicture}
  \node (0) {};
  \node (1) [draw, text height = 3.9pt, right = -0.9pt of 0, thick, inner sep = 5pt] {$m$};
  \node (2) [draw, right = -0.9pt of 1, thick, inner sep = 5pt] {$0$};
  \node (3) [draw, right = -0.9pt of 2, thick, inner sep = 5pt] {$0$};
  \node (4) [draw, right = -0.9pt of 3, thick, inner sep = 5pt] {$1$};
  \node (5) [draw, right = -0.9pt of 4, thick, inner sep = 5pt] {$0$};
  \node (6) [right = -0.9pt of 5] {\ldots \ldots};
  \node (7) [draw, right = -0.9pt of 6, thick, inner sep = 5pt] {$0$};
  \node (8) [draw, text height = 3.9pt, right = -0.9pt of 7, thick, inner sep = 5pt] {$r$};
  \draw [->, >=latex, thick] (7)+(0, -4\baseheight) -- (7);
\end{tikzpicture}}
\caption{The third situation for TM $mainwork$ to consider} \label{mainwork_case_three_input}
\end{figure}

\begin{figure}[h!]
\centering
\scalebox{1.2}{
\begin{tikzpicture}
  \node (0) {};
  \node (1) [draw, text height = 3.9pt, right = -0.9pt of 0, thick, inner sep = 5pt] {$m$};
  \node (2) [draw, right = -0.9pt of 1, thick, inner sep = 5pt] {$0$};
  \node (3) [draw, right = -0.9pt of 2, thick, inner sep = 5pt] {$0$};
  \node (4) [draw, right = -0.9pt of 3, thick, inner sep = 5pt] {$1$};
  \node (5) [draw, right = -0.9pt of 4, thick, inner sep = 5pt] {$0$};
  \node (6) [right = -0.9pt of 5] {\ldots \ldots};
  \node (7) [draw, right = -0.9pt of 6, thick, inner sep = 5pt] {$0$};
  \node (8) [draw, text height = 3.9pt, right = -0.9pt of 7, thick, inner sep = 5pt] {$r$};
  \draw [->, >=latex, thick] (3)+(0, -4\baseheight) -- (3);
\end{tikzpicture}}
\caption{The output for the third case of TM $mainwork$'s processing}
\label{mainwork_case_three_output}
\end{figure}

\begin{figure}[h!]
\centering
\scalebox{0.9}{
\begin{tikzpicture}
     \node[circle,draw] (1) {$1$};
     \node[circle,draw] (2) at ($(1)+(0.3\basewidth, 0)$) {$2$};
     \node[circle,draw] (3) at ($(2)+(0.3\basewidth, 0)$) {$3$};
     \node[circle,draw] (4) at ($(3)+(0.3\basewidth, 0)$) {$4$};
     \node[circle,draw] (5) at ($(4)+(0.3\basewidth, 0)$) {$5$};
     \node[circle,draw] (6) at ($(5)+(0.3\basewidth, 0)$) {$6$};
     \node[circle,draw] (7) at ($(2)+(0, -7\baseheight)$) {$7$};
     \node[circle,draw] (8) at ($(7)+(0, -7\baseheight)$) {$8$};
     \node[circle,draw] (9) at ($(8)+(0.3\basewidth, 0)$) {$9$};
     \node[circle,draw] (10) at ($(9)+(0.3\basewidth, 0)$) {$10$};
     \node[circle,draw] (11) at ($(10)+(0.3\basewidth, 0)$) {$11$};
     \node[circle,draw] (12) at ($(11)+(0.3\basewidth, 0)$) {$12$};
     \node[draw] (13) at ($(6)+(0.3\basewidth, 0)$) {$2 \times x$};
     \node[circle,draw] (14) at ($(13)+(0.3\basewidth, 0)$) {$j_1$};
     \node[draw] (15) at ($(12)+(0.3\basewidth, 0)$) {$4 \times x$};
     \node[draw] (16) at ($(15)+(0.3\basewidth, 0)$) {$j_2$};
     \node[draw] (17) at ($(7)+(0.3\basewidth, 0)$) {$0$};

     \draw [->, >=latex] (1) edge[loop left] node[above] {$S_0:L$} (1)
     ;
     \draw [->, >=latex] (1) -- node[above] {$S_1:L$} (2)
     ;
     \draw [->, >=latex] (2) -- node[above] {$S_1:R$} (3)
     ;
     \draw [->, >=latex] (2) -- node[left] {$S_1:L$} (7)
     ;
     \draw [->, >=latex] (3) edge[loop above] node[above] {$S_1:S_0$} (3)
     ;
     \draw [->, >=latex] (3) -- node[above] {$S_0:R$} (4)
     ;
     \draw [->, >=latex] (4) edge[loop above] node[above] {$S_0:R$} (4)
     ;
     \draw [->, >=latex] (4) -- node[above] {$S_1:R$} (5)
     ;
     \draw [->, >=latex] (5) edge[loop above] node[above] {$S_1:R$} (5)
     ;
     \draw [->, >=latex] (5) -- node[above] {$S_0:S_1$} (6)
     ;
     \draw [->, >=latex] (6) edge[loop above] node[above] {$S_1:L$} (6)
     ;
     \draw [->, >=latex] (6) -- node[above] {$S_0:R$} (13)
     ;
     \draw [->, >=latex] (13) -- (14)
     ;
     \draw (14) -- ($(14)+(0, 6\baseheight)$) -- ($(1) + (0, 6\baseheight)$) node [above,midway] {$S_1:L$}
     ;
     \draw [->, >=latex] ($(1) + (0, 6\baseheight)$) -- (1)
     ;
     \draw [->, >=latex] (7) -- node[above] {$S_0:R$} (17)
     ;
     \draw [->, >=latex] (7) -- node[left] {$S_1:R$} (8)
     ;
     \draw [->, >=latex] (8) -- node[above] {$S_0:R$} (9)
     ;
     \draw [->, >=latex] (9) -- node[above] {$S_0:R$} (10)
     ;
     \draw [->, >=latex] (10) -- node[above] {$S_1:R$} (11)
     ;
     \draw [->, >=latex] (10) edge[loop above] node[above] {$S_0:R$} (10)
     ;
     \draw [->, >=latex] (11) edge[loop above] node[above] {$S_1:R$} (11)
     ;
     \draw [->, >=latex] (11) -- node[above] {$S_0:S_1$} (12)
     ;
     \draw [->, >=latex] (12) -- node[above] {$S_0:R$} (15)
     ;
     \draw [->, >=latex] (12) edge[loop above] node[above] {$S_1:L$} (12)
     ;
     \draw [->, >=latex] (15) -- (16)
     ;
     \draw (16) -- ($(16)+(0, -4\baseheight)$) -- ($(1) + (0, -18\baseheight)$) node [below,midway] {$S_1:L$}
     ;
     \draw [->, >=latex] ($(1) + (0, -18\baseheight)$) -- (1)
     ;
 \end{tikzpicture}}
\caption{The diagram of TM $mainwork$} \label{mainwork_diag}
\end{figure}

The purpose of TM $adjust$ is to encode the last bit of $a_1$. The initial and final configuration
of this TM are shown in Figure \ref{adjust_initial} and \ref{adjust_final} respectively.
The diagram of TM $adjust$ is shown in Figure \ref{adjust_diag}.


\begin{figure}[h!]
\centering
\scalebox{1.2}{
\begin{tikzpicture}
  \node (0) {};
  \node (1) [draw, text height = 3.9pt, right = -0.9pt of 0, thick, inner sep = 5pt] {$m$};
  \node (2) [draw, right = -0.9pt of 1, thick, inner sep = 5pt] {$0$};
  \node (3) [draw, right = -0.9pt of 2, thick, inner sep = 5pt] {$0$};
  \node (4) [draw, right = -0.9pt of 3, thick, inner sep = 5pt] {$1$};
  \node (5) [draw, right = -0.9pt of 4, thick, inner sep = 5pt] {$0$};
  \node (6) [right = -0.9pt of 5] {\ldots \ldots};
  \node (7) [draw, right = -0.9pt of 6, thick, inner sep = 5pt] {$0$};
  \node (8) [draw, text height = 3.9pt, right = -0.9pt of 7, thick, inner sep = 5pt] {$r$};
  \draw [->, >=latex, thick] (3)+(0, -4\baseheight) -- (3);
\end{tikzpicture}}
\caption{Initial configuration of TM $adjust$} \label{adjust_initial}
\end{figure}

\begin{figure}[h!]
\centering
\scalebox{1.2}{
\begin{tikzpicture}
  \node (0) {};
  \node (1) [draw, text height = 3.9pt, right = -0.9pt of 0, thick, inner sep = 5pt] {$m$};
  \node (2) [draw, right = -0.9pt of 1, thick, inner sep = 5pt] {$0$};
  \node (3) [draw, text height = 2.9pt, right = -0.9pt of 2, thick, inner sep = 5pt] {$r+1$};
  \node (4) [draw, right = -0.9pt of 3, thick, inner sep = 5pt] {$0$};
  \node (5) [draw, right = -0.9pt of 4, thick, inner sep = 5pt] {$0$};
  \node (6) [right = -0.9pt of 5] {\ldots \ldots};
  \draw [->, >=latex, thick] (1)+(0, -4\baseheight) -- (1);
\end{tikzpicture}}
\caption{Final configuration of TM $adjust$} \label{adjust_final}
\end{figure}


\begin{figure}[h!]
\centering
\scalebox{0.9}{
\begin{tikzpicture}
     \node[circle,draw] (1) {$1$};
     \node[circle,draw] (2) at ($(1)+(0.3\basewidth, 0)$) {$2$};
     \node[circle,draw] (3) at ($(2)+(0.3\basewidth, 0)$) {$3$};
     \node[circle,draw] (4) at ($(3)+(0.3\basewidth, 0)$) {$4$};
     \node[circle,draw] (5) at ($(4)+(0.3\basewidth, 0)$) {$5$};
     \node[circle,draw] (6) at ($(5)+(0.3\basewidth, 0)$) {$6$};
     \node[circle,draw] (7) at ($(6)+(0.3\basewidth, 0)$) {$7$};
     \node[circle,draw] (8) at ($(4)+(0, -7\baseheight)$) {$8$};
     \node[circle,draw] (9) at ($(8)+(0.3\basewidth, 0)$) {$9$};
     \node[circle,draw] (10) at ($(9)+(0.3\basewidth, 0)$) {$10$};
     \node[circle,draw] (11) at ($(10)+(0.3\basewidth, 0)$) {$11$};
     \node[circle,draw] (12) at ($(11)+(0.3\basewidth, 0)$) {$0$};


     \draw [->, >=latex] (1) -- node[above] {$S_1:R$} (2)
     ;
     \draw [->, >=latex] (1) edge[loop above] node[above] {$S_0:S_1$} (1)
     ;
     \draw [->, >=latex] (2) -- node[above] {$S_1:R$} (3)
     ;
     \draw [->, >=latex] (3) edge[loop above] node[above] {$S_0:R$} (3)
     ;
     \draw [->, >=latex] (3) -- node[above] {$S_1:R$} (4)
     ;
     \draw [->, >=latex] (4) -- node[above] {$S_1:L$} (5)
     ;
     \draw [->, >=latex] (4) -- node[right] {$S_0:L$} (8)
     ;
     \draw [->, >=latex] (5) -- node[above] {$S_0:L$} (6)
     ;
     \draw [->, >=latex] (5) edge[loop above] node[above] {$S_1:S_0$} (5)
     ;
     \draw [->, >=latex] (6) -- node[above] {$S_1:R$} (7)
     ;
     \draw [->, >=latex] (6) edge[loop above] node[above] {$S_0:L$} (6)
     ;
     \draw (7) -- ($(7)+(0, 6\baseheight)$) -- ($(2) + (0, 6\baseheight)$) node [above,midway] {$S_0:S_1$}
     ;
     \draw [->, >=latex] ($(2) + (0, 6\baseheight)$) -- (2)
     ;
     \draw [->, >=latex] (8) edge[loop left] node[left] {$S_1:S_0$} (8)
     ;
     \draw [->, >=latex] (8) -- node[above] {$S_0:L$} (9)
     ;
     \draw [->, >=latex] (9) edge[loop above] node[above] {$S_0:L$} (9)
     ;
     \draw [->, >=latex] (9) -- node[above] {$S_1:L$} (10)
     ;
     \draw [->, >=latex] (10) edge[loop above] node[above] {$S_0:L$} (10)
     ;
     \draw [->, >=latex] (10) -- node[above] {$S_0:L$} (11)
     ;
     \draw [->, >=latex] (11) edge[loop above] node[above] {$S_1:L$} (11)
     ;
     \draw [->, >=latex] (11) -- node[above] {$S_0:R$} (12)
     ;
 \end{tikzpicture}}
\caption{Diagram of TM $adjust$} \label{adjust_diag}
\end{figure}
›


definition rec_twice :: "recf"
  where
    "rec_twice = Cn 1 rec_mult [id 1 0, constn 2]"

definition rec_fourtimes  :: "recf"
  where
    "rec_fourtimes = Cn 1 rec_mult [id 1 0, constn 4]"

definition abc_twice :: "abc_prog"
  where
    "abc_twice = (let (aprog, ary, fp) = rec_ci rec_twice in 
                       aprog [+] dummy_abc ((Suc 0)))"

definition abc_fourtimes :: "abc_prog"
  where
    "abc_fourtimes = (let (aprog, ary, fp) = rec_ci rec_fourtimes in 
                       aprog [+] dummy_abc ((Suc 0)))"

definition twice_ly :: "nat list"
  where
    "twice_ly = layout_of abc_twice"

definition fourtimes_ly :: "nat list"
  where
    "fourtimes_ly = layout_of abc_fourtimes"

definition t_twice_compile :: "instr list"
  where
    "t_twice_compile= (tm_of abc_twice @ (shift (mopup 1) (length (tm_of abc_twice) div 2)))"

definition t_twice :: "instr list"
  where
    "t_twice = adjust0 t_twice_compile"

definition t_fourtimes_compile :: "instr list"
  where
    "t_fourtimes_compile= (tm_of abc_fourtimes @ (shift (mopup 1) (length (tm_of abc_fourtimes) div 2)))"

definition t_fourtimes :: "instr list"
  where
    "t_fourtimes = adjust0 t_fourtimes_compile"

definition t_twice_len :: "nat"
  where
    "t_twice_len = length t_twice div 2"

definition t_wcode_main_first_part:: "instr list"
  where
    "t_wcode_main_first_part  
                   [(L, 1), (L, 2), (L, 7), (R, 3),
                    (R, 4), (W0, 3), (R, 4), (R, 5),
                    (W1, 6), (R, 5), (R, 13), (L, 6),
                    (R, 0), (R, 8), (R, 9), (Nop, 8),
                    (R, 10), (W0, 9), (R, 10), (R, 11), 
                    (W1, 12), (R, 11), (R, t_twice_len + 14), (L, 12)]"

definition t_wcode_main :: "instr list"
  where
    "t_wcode_main = (t_wcode_main_first_part @ shift t_twice 12 @ [(L, 1), (L, 1)]
                    @ shift t_fourtimes (t_twice_len + 13) @ [(L, 1), (L, 1)])"

fun bl_bin :: "cell list  nat"
  where
    "bl_bin [] = 0" 
  | "bl_bin (Bk # xs) = 2 * bl_bin xs"
  | "bl_bin (Oc # xs) = Suc (2 * bl_bin xs)"

declare bl_bin.simps[simp del]

type_synonym bin_inv_t = "cell list  nat  tape  bool"

fun wcode_before_double :: "bin_inv_t"
  where
    "wcode_before_double ires rs (l, r) =
     ( ln rn. l = Bk # Bk # Bk(ln) @ Oc # ires  
               r = Oc((Suc (Suc rs))) @ Bk(rn ))"

declare wcode_before_double.simps[simp del]

fun wcode_after_double :: "bin_inv_t"
  where
    "wcode_after_double ires rs (l, r) = 
     ( ln rn. l = Bk # Bk # Bk(ln) @ Oc # ires 
         r = Oc(Suc (Suc (Suc 2*rs))) @ Bk(rn))"

declare wcode_after_double.simps[simp del]

fun wcode_on_left_moving_1_B :: "bin_inv_t"
  where
    "wcode_on_left_moving_1_B ires rs (l, r) = 
     ( ml mr rn. l = Bk(ml) @ Oc # Oc # ires  
               r = Bk(mr) @ Oc(Suc rs) @ Bk(rn) 
               ml + mr > Suc 0  mr > 0)"

declare wcode_on_left_moving_1_B.simps[simp del]

fun wcode_on_left_moving_1_O :: "bin_inv_t"
  where
    "wcode_on_left_moving_1_O ires rs (l, r) = 
     ( ln rn.
               l = Oc # ires  
               r = Oc # Bk(ln) @ Bk # Bk # Oc(Suc rs) @ Bk(rn))"

declare wcode_on_left_moving_1_O.simps[simp del]

fun wcode_on_left_moving_1 :: "bin_inv_t"
  where
    "wcode_on_left_moving_1 ires rs (l, r) = 
          (wcode_on_left_moving_1_B ires rs (l, r)  wcode_on_left_moving_1_O ires rs (l, r))"

declare wcode_on_left_moving_1.simps[simp del]

fun wcode_on_checking_1 :: "bin_inv_t"
  where
    "wcode_on_checking_1 ires rs (l, r) = 
    ( ln rn. l = ires 
              r = Oc # Oc # Bk(ln) @ Bk # Bk # Oc(Suc rs) @ Bk(rn))"

fun wcode_erase1 :: "bin_inv_t"
  where
    "wcode_erase1 ires rs (l, r) = 
       ( ln rn. l = Oc # ires  
                 tl r = Bk(ln) @ Bk # Bk # Oc(Suc rs) @ Bk(rn))"

declare wcode_erase1.simps [simp del]

fun wcode_on_right_moving_1 :: "bin_inv_t"
  where
    "wcode_on_right_moving_1 ires rs (l, r) = 
       ( ml mr rn.        
             l = Bk(ml) @ Oc # ires  
             r = Bk(mr) @ Oc(Suc rs) @ Bk(rn) 
             ml + mr > Suc 0)"

declare wcode_on_right_moving_1.simps [simp del] 

declare wcode_on_right_moving_1.simps[simp del]

fun wcode_goon_right_moving_1 :: "bin_inv_t"
  where
    "wcode_goon_right_moving_1 ires rs (l, r) = 
      ( ml mr ln rn. 
            l = Oc(ml) @ Bk # Bk # Bk(ln) @ Oc # ires  
            r = Oc(mr) @ Bk(rn) 
            ml + mr = Suc rs)"

declare wcode_goon_right_moving_1.simps[simp del]

fun wcode_backto_standard_pos_B :: "bin_inv_t"
  where
    "wcode_backto_standard_pos_B ires rs (l, r) = 
          ( ln rn. l =  Bk # Bk(ln) @ Oc # ires  
               r =  Bk # Oc((Suc (Suc rs))) @ Bk(rn ))"

declare wcode_backto_standard_pos_B.simps[simp del]

fun wcode_backto_standard_pos_O :: "bin_inv_t"
  where
    "wcode_backto_standard_pos_O ires rs (l, r) = 
        ( ml mr ln rn. 
            l = Oc(ml) @ Bk # Bk # Bk(ln) @ Oc # ires 
            r = Oc(mr) @ Bk(rn) 
            ml + mr = Suc (Suc rs)  mr > 0)"

declare wcode_backto_standard_pos_O.simps[simp del]

fun wcode_backto_standard_pos :: "bin_inv_t"
  where
    "wcode_backto_standard_pos ires rs (l, r) = (wcode_backto_standard_pos_B ires rs (l, r) 
                                            wcode_backto_standard_pos_O ires rs (l, r))"

declare wcode_backto_standard_pos.simps[simp del]

lemma bin_wc_eq: "bl_bin xs = bl2wc xs"
proof(induct xs)
  show " bl_bin [] = bl2wc []" 
    apply(simp add: bl_bin.simps)
    done
next
  fix a xs
  assume "bl_bin xs = bl2wc xs"
  thus " bl_bin (a # xs) = bl2wc (a # xs)"
    apply(case_tac a, simp_all add: bl_bin.simps bl2wc.simps)
     apply(simp_all add: bl2nat.simps bl2nat_double)
    done
qed

lemma tape_of_nl_append_one: "lm  []   <lm @ [a]> = <lm> @ Bk # OcSuc a"
  apply(induct lm, auto simp: tape_of_nl_cons split:if_splits)
  done

lemma tape_of_nl_rev: "rev (<lm::nat list>) = (<rev lm>)"
  apply(induct lm, simp, auto)
  apply(auto simp: tape_of_nl_cons tape_of_nl_append_one split: if_splits)
  apply(simp add: exp_ind[THEN sym])
  done

lemma exp_1[simp]: "a(Suc 0) = [a]" 
  by(simp)

lemma tape_of_nl_cons_app1: "(<a # xs @ [b]>) = (Oc(Suc a) @ Bk # (<xs@ [b]>))"
  apply(case_tac xs; simp add: tape_of_list_def tape_of_nat_list.simps tape_of_nat_def)
  done

lemma bl_bin_bk_oc[simp]:
  "bl_bin (xs @ [Bk, Oc]) = 
  bl_bin xs + 2*2^(length xs)"
  apply(simp add: bin_wc_eq)
  using bl2nat_cons_oc[of "xs @ [Bk]"]
  apply(simp add: bl2nat_cons_bk bl2wc.simps)
  done

lemma tape_of_nat[simp]: "(<a::nat>) = Oc(Suc a)"
  apply(simp add: tape_of_nat_def)
  done

lemma tape_of_nl_cons_app2: "(<c # xs @ [b]>) = (<c # xs> @ Bk # Oc(Suc b))"
proof(induct "length xs" arbitrary: xs c, simp add: tape_of_list_def)
  fix x xs c
  assume ind: "xs c. x = length xs  <c # xs @ [b]> = 
    <c # xs> @ Bk # Oc(Suc b)"
    and h: "Suc x = length (xs::nat list)" 
  show "<c # xs @ [b]> = <c # xs> @ Bk # Oc(Suc b)"
  proof(cases xs, simp add: tape_of_list_def)
    fix a list
    assume g: "xs = a # list"
    hence k: "<a # list @ [b]> =  <a # list> @ Bk # Oc(Suc b)"
      apply(rule_tac ind)
      using h
      apply(simp)
      done
    from g and k show "<c # xs @ [b]> = <c # xs> @ Bk # Oc(Suc b)"
      apply(simp add: tape_of_list_def)
      done
  qed
qed

lemma length_2_elems[simp]: "length (<aa # a # list>) = Suc (Suc aa) + length (<a # list>)"
  apply(simp add: tape_of_list_def)
  done

lemma bl_bin_addition[simp]: "bl_bin (Oc(Suc aa) @ Bk # tape_of_nat_list (a # lista) @ [Bk, Oc]) =
              bl_bin (Oc(Suc aa) @ Bk # tape_of_nat_list (a # lista)) + 
              2* 2^(length (Oc(Suc aa) @ Bk # tape_of_nat_list (a # lista)))"
  using bl_bin_bk_oc[of "Oc(Suc aa) @ Bk # tape_of_nat_list (a # lista)"]
  apply(simp)
  done

declare replicate_Suc[simp del]

lemma bl_bin_2[simp]: 
  "bl_bin (<aa # list>) + (4 * rs + 4) * 2 ^ (length (<aa # list>) - Suc 0)
  = bl_bin (Oc(Suc aa) @ Bk # <list @ [0]>) + rs * (2 * 2 ^ (aa + length (<list @ [0]>)))"
  apply(case_tac "list", simp add: add_mult_distrib)
  apply(simp add: tape_of_nl_cons_app2 add_mult_distrib)
  apply(simp add: tape_of_list_def)
  done

lemma tape_of_nl_app_Suc: "((<list @ [Suc ab]>)) = (<list @ [ab]>) @ [Oc]"
proof(induct list)
  case (Cons a list)
  then show ?case by(cases list;simp_all add:tape_of_list_def exp_ind)
qed (simp add: tape_of_list_def exp_ind)

lemma bl_bin_3[simp]: "bl_bin (Oc # Oc(aa) @ Bk # <list @ [ab]> @ [Oc])
              = bl_bin (Oc # Oc(aa) @ Bk # <list @ [ab]>) +
              2^(length (Oc # Oc(aa) @ Bk # <list @ [ab]>))"
  apply(simp add: bin_wc_eq)
  apply(simp add: bl2nat_cons_oc bl2wc.simps)
  using bl2nat_cons_oc[of "Oc # Oc(aa) @ Bk # <list @ [ab]>"]
  apply(simp)
  done
lemma bl_bin_4[simp]: "bl_bin (Oc # Oc(aa) @ Bk # <list @ [ab]>) + (4 * 2 ^ (aa + length (<list @ [ab]>)) +
         4 * (rs * 2 ^ (aa + length (<list @ [ab]>)))) =
       bl_bin (Oc # Oc(aa) @ Bk # <list @ [Suc ab]>) +
         rs * (2 * 2 ^ (aa + length (<list @ [Suc ab]>)))"
  apply(simp add: tape_of_nl_app_Suc)
  done

declare tape_of_nat[simp del]

fun wcode_double_case_inv :: "nat  bin_inv_t"
  where
    "wcode_double_case_inv st ires rs (l, r) = 
          (if st = Suc 0 then wcode_on_left_moving_1 ires rs (l, r)
          else if st = Suc (Suc 0) then wcode_on_checking_1 ires rs (l, r)
          else if st = 3 then wcode_erase1 ires rs (l, r)
          else if st = 4 then wcode_on_right_moving_1 ires rs (l, r)
          else if st = 5 then wcode_goon_right_moving_1 ires rs (l, r)
          else if st = 6 then wcode_backto_standard_pos ires rs (l, r)
          else if st = 13 then wcode_before_double ires rs (l, r)
          else False)"

declare wcode_double_case_inv.simps[simp del]

fun wcode_double_case_state :: "config  nat"
  where
    "wcode_double_case_state (st, l, r) = 
   13 - st"

fun wcode_double_case_step :: "config  nat"
  where
    "wcode_double_case_step (st, l, r) = 
      (if st = Suc 0 then (length l)
      else if st = Suc (Suc 0) then (length r)
      else if st = 3 then 
                 if hd r = Oc then 1 else 0
      else if st = 4 then (length r)
      else if st = 5 then (length r)
      else if st = 6 then (length l)
      else 0)"

fun wcode_double_case_measure :: "config  nat × nat"
  where
    "wcode_double_case_measure (st, l, r) = 
     (wcode_double_case_state (st, l, r), 
      wcode_double_case_step (st, l, r))"

definition wcode_double_case_le :: "(config × config) set"
  where "wcode_double_case_le  (inv_image lex_pair wcode_double_case_measure)"

lemma wf_lex_pair[intro]: "wf lex_pair"
  by(auto intro:wf_lex_prod simp:lex_pair_def)

lemma wf_wcode_double_case_le[intro]: "wf wcode_double_case_le"
  by(auto intro:wf_inv_image simp: wcode_double_case_le_def )

lemma fetch_t_wcode_main[simp]:
  "fetch t_wcode_main (Suc 0) Bk = (L, Suc 0)"
  "fetch t_wcode_main (Suc 0) Oc = (L, Suc (Suc 0))"
  "fetch t_wcode_main (Suc (Suc 0)) Oc = (R, 3)"
  "fetch t_wcode_main (Suc (Suc 0)) Bk = (L, 7)"
  "fetch t_wcode_main (Suc (Suc (Suc 0))) Bk = (R, 4)"
  "fetch t_wcode_main (Suc (Suc (Suc 0))) Oc = (W0, 3)"
  "fetch t_wcode_main 4 Bk = (R, 4)"
  "fetch t_wcode_main 4 Oc = (R, 5)"
  "fetch t_wcode_main 5 Oc = (R, 5)"
  "fetch t_wcode_main 5 Bk = (W1, 6)"
  "fetch t_wcode_main 6 Bk = (R, 13)"
  "fetch t_wcode_main 6 Oc = (L, 6)"
  "fetch t_wcode_main 7 Oc = (R, 8)"
  "fetch t_wcode_main 7 Bk = (R, 0)"
  "fetch t_wcode_main 8 Bk = (R, 9)"
  "fetch t_wcode_main 9 Bk = (R, 10)"
  "fetch t_wcode_main 9 Oc = (W0, 9)"
  "fetch t_wcode_main 10 Bk = (R, 10)"
  "fetch t_wcode_main 10 Oc = (R, 11)"
  "fetch t_wcode_main 11 Bk = (W1, 12)"
  "fetch t_wcode_main 11 Oc = (R, 11)"
  "fetch t_wcode_main 12 Oc = (L, 12)"
  "fetch t_wcode_main 12 Bk = (R, t_twice_len + 14)"
  by(auto simp: t_wcode_main_def t_wcode_main_first_part_def fetch.simps numeral)

declare wcode_on_checking_1.simps[simp del]

lemmas wcode_double_case_inv_simps = 
  wcode_on_left_moving_1.simps wcode_on_left_moving_1_O.simps
  wcode_on_left_moving_1_B.simps wcode_on_checking_1.simps
  wcode_erase1.simps wcode_on_right_moving_1.simps
  wcode_goon_right_moving_1.simps wcode_backto_standard_pos.simps


lemma wcode_on_left_moving_1[simp]:
  "wcode_on_left_moving_1 ires rs (b, []) = False"
  "wcode_on_left_moving_1 ires rs (b, r)  b  []"
  by(auto simp: wcode_on_left_moving_1.simps wcode_on_left_moving_1_B.simps
      wcode_on_left_moving_1_O.simps)

lemma wcode_on_left_moving_1E[elim]: "wcode_on_left_moving_1 ires rs (b, Bk # list);
                tl b = aa  hd b # Bk # list = ba  
               wcode_on_left_moving_1 ires rs (aa, ba)"
  apply(simp only: wcode_on_left_moving_1.simps wcode_on_left_moving_1_O.simps
      wcode_on_left_moving_1_B.simps)
  apply(erule_tac disjE)
   apply(erule_tac exE)+
   apply(rename_tac ml mr rn)
   apply(case_tac ml, simp)
    apply(rule_tac x = "mr - Suc (Suc 0)" in exI, rule_tac x = rn in exI)
    apply (smt One_nat_def Suc_diff_Suc append_Cons empty_replicate list.sel(3) neq0_conv replicate_Suc replicate_app_Cons_same tl_append2 tl_replicate)
   apply(rule_tac disjI1)
   apply (metis add_Suc_shift less_SucI list.exhaust_sel list.inject list.simps(3) replicate_Suc_iff_anywhere)
  by simp

declare replicate_Suc[simp]

lemma wcode_on_moving_1_Elim[elim]: 
  "wcode_on_left_moving_1 ires rs (b, Oc # list); tl b = aa  hd b # Oc # list = ba 
     wcode_on_checking_1 ires rs (aa, ba)"
  apply(simp only: wcode_double_case_inv_simps)
  apply(erule_tac disjE)
   apply (metis cell.distinct(1) empty_replicate hd_append2 hd_replicate list.sel(1) not_gr_zero)
  apply force.

lemma wcode_on_checking_1_Elim[elim]: "wcode_on_checking_1 ires rs (b, Oc # ba);Oc # b = aa  list = ba
   wcode_erase1 ires rs (aa, ba)"
  apply(simp only: wcode_double_case_inv_simps)
  apply(erule_tac exE)+ by auto

lemma wcode_on_checking_1_simp[simp]:
  "wcode_on_checking_1 ires rs (b, []) = False" 
  "wcode_on_checking_1 ires rs (b, Bk # list) = False"
  by(auto simp: wcode_double_case_inv_simps)

lemma wcode_erase1_nonempty_snd[simp]: "wcode_erase1 ires rs (b, []) = False"
  apply(simp add: wcode_double_case_inv_simps)
  done

lemma wcode_on_right_moving_1_nonempty_snd[simp]: "wcode_on_right_moving_1 ires rs (b, []) = False"
  apply(simp add: wcode_double_case_inv_simps)
  done

lemma wcode_on_right_moving_1_BkE[elim]:
  "wcode_on_right_moving_1 ires rs (b, Bk # ba);  Bk # b = aa  list = b  
  wcode_on_right_moving_1 ires rs (aa, ba)"
  apply(simp only: wcode_double_case_inv_simps)
  apply(erule_tac exE)+
  apply(rename_tac ml mr rn)
  apply(rule_tac x = "Suc ml" in exI, rule_tac x = "mr - Suc 0" in exI,
      rule_tac x = rn in exI)
  apply(simp)
  apply(case_tac mr, simp, simp)
  done

lemma wcode_on_right_moving_1_OcE[elim]: 
  "wcode_on_right_moving_1 ires rs (b, Oc # ba); Oc # b = aa  list = ba 
   wcode_goon_right_moving_1 ires rs (aa, ba)"
  apply(simp only: wcode_double_case_inv_simps)
  apply(erule_tac exE)+
  apply(rename_tac ml mr rn)
  apply(rule_tac x = "Suc 0" in exI, rule_tac x = "rs" in exI,
      rule_tac x = "ml - Suc (Suc 0)" in exI, rule_tac x = rn in exI)
  apply(case_tac mr, simp_all)
  apply(case_tac ml, simp, case_tac nat, simp, simp)
  done

lemma wcode_erase1_BkE[elim]:
  assumes "wcode_erase1 ires rs (b, Bk # ba)" "Bk # b = aa  list = ba" "c = Bk # ba"
  shows "wcode_on_right_moving_1 ires rs (aa, ba)"
proof -
  from assms obtain rn ln where "b = Oc # ires"
    "tl (Bk # ba) = Bk  ln @ Bk # Bk # Oc  Suc rs @ Bk  rn"
    unfolding wcode_double_case_inv_simps by auto
  thus ?thesis using assms(2-) unfolding wcode_double_case_inv_simps
    apply(rule_tac x = "Suc 0" in exI, rule_tac x = "Suc (Suc ln)" in exI, 
        rule_tac x = rn in exI, simp add: exp_ind del: replicate_Suc)
    done
qed

lemma wcode_erase1_OcE[elim]: "wcode_erase1 ires rs (aa, Oc # list);  b = aa  Bk # list = ba  
  wcode_erase1 ires rs (aa, ba)"
  unfolding wcode_double_case_inv_simps
  by auto auto

lemma wcode_goon_right_moving_1_emptyE[elim]:
  assumes "wcode_goon_right_moving_1 ires rs (aa, [])" "b = aa  [Oc] = ba"
  shows "wcode_backto_standard_pos ires rs (aa, ba)"
proof -
  from assms obtain ml ln rn mr where "aa = Oc  ml @ Bk # Bk # Bk  ln @ Oc # ires"
    "[] = Oc  mr @ Bk  rn" "ml + mr = Suc rs"
    by(auto simp:wcode_double_case_inv_simps)
  thus ?thesis using assms(2)
    apply(simp only: wcode_double_case_inv_simps)
    apply(rule_tac disjI2)
    apply(simp only:wcode_backto_standard_pos_O.simps)
    apply(rule_tac x = ml in exI, rule_tac x = "Suc 0" in exI, rule_tac x = ln in exI,
        rule_tac x = rn in exI, simp)
    done
qed

lemma wcode_goon_right_moving_1_BkE[elim]: 
  assumes "wcode_goon_right_moving_1 ires rs (aa, Bk # list)" "b = aa  Oc # list = ba"
  shows "wcode_backto_standard_pos ires rs (aa, ba)"
proof -
  from assms obtain ln rn where "aa = Oc  Suc rs @ Bk  Suc (Suc ln) @ Oc # ires"
    "Bk # list = Bk  rn" "b = Oc  Suc rs @ Bk  Suc (Suc ln) @ Oc # ires" "ba = Oc # list"
    by(auto simp:wcode_double_case_inv_simps)
  thus ?thesis using assms(2)
    apply(simp only: wcode_double_case_inv_simps wcode_backto_standard_pos_O.simps)
    apply(rule_tac disjI2)
    apply(rule exI[of _ "Suc rs"], rule exI[of _ "Suc 0"], rule_tac x = ln in exI,
        rule_tac x = "rn - Suc 0" in exI, simp)
    apply(cases rn;auto)
    done
qed

lemma wcode_goon_right_moving_1_OcE[elim]: 
  assumes "wcode_goon_right_moving_1 ires rs (b, Oc # ba)" "Oc # b = aa  list = ba"
  shows "wcode_goon_right_moving_1 ires rs (aa, ba)"
proof -
  from assms obtain ml mr ln rn where
    "b = Oc  ml @ Bk # Bk # Bk  ln @ Oc # ires 
       Oc # ba = Oc  mr @ Bk  rn  ml + mr = Suc rs"
    unfolding wcode_double_case_inv_simps by auto
  with assms(2) show ?thesis unfolding wcode_double_case_inv_simps
    apply(rule_tac x = "Suc ml" in exI, rule_tac x = "mr - Suc 0" in exI, 
        rule_tac x = ln in exI, rule_tac x = rn in exI)
    apply(simp)
    apply(case_tac mr, simp, case_tac rn, simp_all)
    done
qed


lemma wcode_backto_standard_pos_BkE[elim]: "wcode_backto_standard_pos ires rs (b, Bk # ba); Bk # b = aa  list = ba 
   wcode_before_double ires rs (aa, ba)"
  apply(simp only: wcode_double_case_inv_simps wcode_backto_standard_pos_B.simps
      wcode_backto_standard_pos_O.simps wcode_before_double.simps)
  apply(erule_tac disjE)
   apply(erule_tac exE)+ 
  by auto

lemma wcode_backto_standard_pos_no_Oc[simp]: "wcode_backto_standard_pos ires rs ([], Oc # list) = False"
  apply(auto simp: wcode_backto_standard_pos.simps wcode_backto_standard_pos_B.simps
      wcode_backto_standard_pos_O.simps)
  done

lemma wcode_backto_standard_pos_nonempty_snd[simp]: "wcode_backto_standard_pos ires rs (b, []) = False"
  apply(auto simp: wcode_backto_standard_pos.simps wcode_backto_standard_pos_B.simps
      wcode_backto_standard_pos_O.simps)
  done

lemma wcode_backto_standard_pos_OcE[elim]: "wcode_backto_standard_pos ires rs (b, Oc # list); tl b = aa; hd b # Oc # list =  ba
        wcode_backto_standard_pos ires rs (aa, ba)"
  apply(simp only:  wcode_backto_standard_pos.simps wcode_backto_standard_pos_B.simps
      wcode_backto_standard_pos_O.simps)
  apply(erule_tac disjE)
   apply(simp)
  apply(erule_tac exE)+ 
  apply(simp)
  apply (rename_tac ml mr ln rn)
  apply(case_tac ml)
   apply(rule_tac disjI1, rule_tac conjI)
    apply(rule_tac x = ln  in exI, force, rule_tac x = rn in exI, force, force).

declare nth_of.simps[simp del] fetch.simps[simp del]
lemma wcode_double_case_first_correctness:
  "let P = (λ (st, l, r). st = 13) in 
       let Q = (λ (st, l, r). wcode_double_case_inv st ires rs (l, r)) in 
       let f = (λ stp. steps0 (Suc 0, Bk # Bk(m) @ Oc # Oc # ires, Bk # Oc(Suc rs) @ Bk(n)) t_wcode_main stp) in
        n .P (f n)  Q (f (n::nat))"
proof -
  let ?P = "(λ (st, l, r). st = 13)"
  let ?Q = "(λ (st, l, r). wcode_double_case_inv st ires rs (l, r))"
  let ?f = "(λ stp. steps0 (Suc 0, Bk # Bk(m) @ Oc # Oc # ires, Bk # Oc(Suc rs) @ Bk(n)) t_wcode_main stp)"
  have " n. ?P (?f n)  ?Q (?f (n::nat))"
  proof(rule_tac halt_lemma2)
    show "wf wcode_double_case_le"
      by auto
  next
    show " na. ¬ ?P (?f na)  ?Q (?f na) 
                   ?Q (?f (Suc na))  (?f (Suc na), ?f na)  wcode_double_case_le"
    proof(rule_tac allI, case_tac "?f na", simp)
      fix na a b c
      show "a  13  wcode_double_case_inv a ires rs (b, c) 
               (case step0 (a, b, c) t_wcode_main of (st, x)  
                   wcode_double_case_inv st ires rs x)  
                (step0 (a, b, c) t_wcode_main, a, b, c)  wcode_double_case_le"
        apply(rule_tac impI, simp add: wcode_double_case_inv.simps)
        apply(auto split: if_splits simp: step.simps, 
            case_tac [!] c, simp_all, case_tac [!] "(c::cell list)!0")
                            apply(simp_all add: wcode_double_case_inv.simps wcode_double_case_le_def
            lex_pair_def)
                      apply(auto split: if_splits)
        done
    qed
  next
    show "?Q (?f 0)"
      apply(simp add: steps.simps wcode_double_case_inv.simps 
          wcode_on_left_moving_1.simps
          wcode_on_left_moving_1_B.simps)
      apply(rule_tac disjI1)
      apply(rule_tac x = "Suc m" in exI, simp)
      apply(rule_tac x = "Suc 0" in exI, simp)
      done
  next
    show "¬ ?P (?f 0)"
      apply(simp add: steps.simps)
      done
  qed
  thus "let P = λ(st, l, r). st = 13;
    Q = λ(st, l, r). wcode_double_case_inv st ires rs (l, r);
    f = steps0 (Suc 0, Bk # Bk(m) @ Oc # Oc # ires, Bk # Oc(Suc rs) @ Bk(n)) t_wcode_main
    in n. P (f n)  Q (f n)"
    apply(simp)
    done
qed

lemma tm_append_shift_append_steps: 
  "steps0 (st, l, r) tp stp = (st', l', r'); 
  0 < st';
  length tp1 mod 2 = 0
  
   steps0 (st + length tp1 div 2, l, r) (tp1 @ shift tp (length tp1 div 2) @ tp2) stp 
  = (st' + length tp1 div 2, l', r')"
proof -
  assume h: 
    "steps0 (st, l, r) tp stp = (st', l', r')"
    "0 < st'"
    "length tp1 mod 2 = 0 "
  from h have 
    "steps (st + length tp1 div 2, l, r) (tp1 @ shift tp (length tp1 div 2), 0) stp = 
                            (st' + length tp1 div 2, l', r')"
    by(rule_tac tm_append_second_steps_eq, simp_all)
  then have "steps (st + length tp1 div 2, l, r) ((tp1 @ shift tp (length tp1 div 2)) @ tp2, 0) stp = 
                            (st' + length tp1 div 2, l', r')"
    using h
    apply(rule_tac tm_append_first_steps_eq, simp_all)
    done
  thus "?thesis"
    by simp
qed 

declare start_of.simps[simp del]

lemma twice_lemma: "rec_exec rec_twice [rs] = 2*rs"
  by(auto simp: rec_twice_def rec_exec.simps)

lemma t_twice_correct: 
  "stp ln rn. steps0 (Suc 0, Bk # Bk # ires, Oc(Suc rs) @ Bk(n)) 
  (tm_of abc_twice @ shift (mopup (Suc 0)) ((length (tm_of abc_twice) div 2))) stp =
  (0, Bk(ln) @ Bk # Bk # ires, Oc(Suc (2 * rs)) @ Bk(rn))"
proof(case_tac "rec_ci rec_twice")
  fix a b c
  assume h: "rec_ci rec_twice = (a, b, c)"
  have "stp m l. steps0 (Suc 0, Bk # Bk # ires, <[rs]> @ Bk(n)) (tm_of abc_twice @ shift (mopup (length [rs])) 
    (length (tm_of abc_twice) div 2)) stp = (0, Bk(m) @ Bk # Bk # ires, Oc(Suc (rec_exec rec_twice [rs])) @ Bk(l))"
    thm  recursive_compile_to_tm_correct1
  proof(rule_tac recursive_compile_to_tm_correct1)
    show "rec_ci rec_twice = (a, b, c)" by (simp add: h)
  next
    show "terminate rec_twice [rs]"
      apply(rule_tac primerec_terminate, auto)
      apply(simp add: rec_twice_def, auto simp: constn.simps numeral_2_eq_2)
      by(auto)
  next
    show "tm_of abc_twice = tm_of (a [+] dummy_abc (length [rs]))"
      using h
      by(simp add: abc_twice_def)
  qed
  thus "?thesis"
    apply(simp add: tape_of_list_def tape_of_nat_def rec_exec.simps twice_lemma)
    done
qed

declare adjust.simps[simp]

lemma adjust_fetch0: 
  "0 < a; a  length ap div 2;  fetch ap a b = (aa, 0)
   fetch (adjust0 ap) a b = (aa, Suc (length ap div 2))"
  apply(case_tac b, auto simp: fetch.simps nth_of.simps nth_map
      split: if_splits)
   apply(case_tac [!] a, auto simp: fetch.simps nth_of.simps)
  done

lemma adjust_fetch_norm: 
  "st > 0;  st  length tp div 2; fetch ap st b = (aa, ns); ns  0
   fetch (adjust0 ap) st b = (aa, ns)"
  apply(case_tac b, auto simp: fetch.simps nth_of.simps nth_map
      split: if_splits)
   apply(case_tac [!] st, auto simp: fetch.simps nth_of.simps)
  done

declare adjust.simps[simp del]

lemma adjust_step_eq: 
  assumes exec: "step0 (st,l,r) ap = (st', l', r')"
    and wf_tm: "tm_wf (ap, 0)"
    and notfinal: "st' > 0"
  shows "step0 (st, l, r) (adjust0 ap) = (st', l', r')"
  using assms
proof -
  have "st > 0"
    using assms
    by(case_tac st, simp_all add: step.simps fetch.simps)
  moreover hence "st  (length ap) div 2"
    using assms
    apply(case_tac "st  (length ap) div 2", simp)
    apply(case_tac st, auto simp: step.simps fetch.simps)
    apply(case_tac "read r", simp_all add: fetch.simps 
        nth_of.simps adjust.simps tm_wf.simps split: if_splits)
     apply(auto simp: mod_ex2)
    done    
  ultimately have "fetch (adjust0 ap) st (read r) = fetch ap st (read r)"
    using assms
    apply(case_tac "fetch ap st (read r)")
    apply(drule_tac adjust_fetch_norm, simp_all)
    apply(simp add: step.simps)
    done
  thus "?thesis"
    using exec
    by(simp add: step.simps)
qed

declare adjust.simps[simp del]

lemma adjust_steps_eq: 
  assumes exec: "steps0 (st,l,r) ap stp = (st', l', r')"
    and wf_tm: "tm_wf (ap, 0)"
    and notfinal: "st' > 0"
  shows "steps0 (st, l, r) (adjust0 ap) stp = (st', l', r')"
  using exec notfinal
proof(induct stp arbitrary: st' l' r')
  case 0
  thus "?case"
    by(simp add: steps.simps)
next
  case (Suc stp st' l' r')
  have ind: "st' l' r'. steps0 (st, l, r) ap stp = (st', l', r'); 0 < st' 
     steps0 (st, l, r) (adjust0 ap) stp = (st', l', r')" by fact
  have h: "steps0 (st, l, r) ap (Suc stp) = (st', l', r')" by fact
  have g:   "0 < st'" by fact
  obtain st'' l'' r'' where a: "steps0 (st, l, r) ap stp = (st'', l'', r'')"
    by (metis prod_cases3)
  hence c:"0 < st''"
    using h g
    apply(simp add: step_red)
    apply(case_tac st'', auto)
    done
  hence b: "steps0 (st, l, r) (adjust0 ap) stp = (st'', l'', r'')"
    using a
    by(rule_tac ind, simp_all)
  thus "?case"
    using assms a b h g
    apply(simp add: step_red) 
    apply(rule_tac adjust_step_eq, simp_all)
    done
qed 

lemma adjust_halt_eq:
  assumes exec: "steps0 (1, l, r) ap stp = (0, l', r')"
    and tm_wf: "tm_wf (ap, 0)" 
  shows " stp. steps0 (Suc 0, l, r) (adjust0 ap) stp = 
        (Suc (length ap div 2), l', r')"
proof -
  have " stp. ¬ is_final (steps0 (1, l, r) ap stp)  (steps0 (1, l, r) ap (Suc stp) = (0, l', r'))"
    using exec
    by(erule_tac before_final)
  then obtain stpa where a: 
    "¬ is_final (steps0 (1, l, r) ap stpa)  (steps0 (1, l, r) ap (Suc stpa) = (0, l', r'))" ..
  obtain sa la ra where b:"steps0 (1, l, r) ap stpa = (sa, la, ra)"  by (metis prod_cases3)
  hence c: "steps0 (Suc 0, l, r) (adjust0 ap) stpa = (sa, la, ra)"
    using assms a
    apply(rule_tac adjust_steps_eq, simp_all)
    done
  have d: "sa  length ap div 2"
    using steps_in_range[of  "(l, r)" ap stpa] a tm_wf b
    by(simp)
  obtain ac ns where e: "fetch ap sa (read ra) = (ac, ns)"
    by (metis prod.exhaust)
  hence f: "ns = 0"
    using b a
    apply(simp add: step_red step.simps)
    done
  have k: "fetch (adjust0 ap) sa (read ra) = (ac, Suc (length ap div 2))"
    using a b c d e f
    apply(rule_tac adjust_fetch0, simp_all)
    done
  from a b e f k and c show "?thesis"
    apply(rule_tac x = "Suc stpa" in exI)
    apply(simp add: step_red, auto)
    apply(simp add: step.simps)
    done
qed    

declare tm_wf.simps[simp del]

lemma tm_wf_t_twice_compile [simp]: "tm_wf (t_twice_compile, 0)"
  apply(simp only: t_twice_compile_def)
  apply(rule_tac wf_tm_from_abacus, simp)
  done

lemma t_twice_change_term_state:
  " stp ln rn. steps0 (Suc 0, Bk # Bk # ires, Oc(Suc rs) @ Bk(n)) t_twice stp
     = (Suc t_twice_len, Bk(ln) @ Bk # Bk # ires, Oc(Suc (2 * rs)) @ Bk(rn))"
proof -
  have "stp ln rn. steps0 (Suc 0, Bk # Bk # ires, Oc(Suc rs) @ Bk(n)) 
    (tm_of abc_twice @ shift (mopup (Suc 0)) ((length (tm_of abc_twice) div 2))) stp =
    (0, Bk(ln) @ Bk # Bk # ires, Oc(Suc (2 * rs)) @ Bk(rn))"
    by(rule_tac t_twice_correct)
  then obtain stp ln rn where " steps0 (Suc 0, Bk # Bk # ires, Oc(Suc rs) @ Bk(n)) 
    (tm_of abc_twice @ shift (mopup (Suc 0)) ((length (tm_of abc_twice) div 2))) stp =
    (0, Bk(ln) @ Bk # Bk # ires, Oc(Suc (2 * rs)) @ Bk(rn))" by blast
  hence " stp. steps0 (Suc 0, Bk # Bk # ires, Oc(Suc rs) @ Bk(n))
    (adjust0 t_twice_compile) stp
     = (Suc (length t_twice_compile div 2), Bk(ln) @ Bk # Bk # ires, Oc(Suc (2 * rs)) @ Bk(rn))"
    apply(rule_tac stp = stp in adjust_halt_eq)
     apply(simp add: t_twice_compile_def, auto)
    done
  then obtain stpb where 
    "steps0 (Suc 0, Bk # Bk # ires, Oc(Suc rs) @ Bk(n))
    (adjust0 t_twice_compile) stpb
     = (Suc (length t_twice_compile div 2), Bk(ln) @ Bk # Bk # ires, Oc(Suc (2 * rs)) @ Bk(rn))" ..
  thus "?thesis"
    apply(simp add: t_twice_def t_twice_len_def)
    by metis
qed

lemma length_t_wcode_main_first_part_even[intro]: "length t_wcode_main_first_part mod 2 = 0"
  apply(auto simp: t_wcode_main_first_part_def)
  done

lemma t_twice_append_pre:
  "steps0 (Suc 0, Bk # Bk # ires, Oc(Suc rs) @ Bk(n)) t_twice stp
  = (Suc t_twice_len, Bk(ln) @ Bk # Bk # ires, Oc(Suc (2 * rs)) @ Bk(rn))
    steps0 (Suc 0 + length t_wcode_main_first_part div 2, Bk # Bk # ires, Oc(Suc rs) @ Bk(n))
     (t_wcode_main_first_part @ shift t_twice (length t_wcode_main_first_part div 2) @
      ([(L, 1), (L, 1)] @ shift t_fourtimes (t_twice_len + 13) @ [(L, 1), (L, 1)])) stp 
    = (Suc (t_twice_len) + length t_wcode_main_first_part div 2, 
             Bk(ln) @ Bk # Bk # ires, Oc(Suc (2 * rs)) @ Bk(rn))"
  by(rule_tac tm_append_shift_append_steps, auto)

lemma t_twice_append:
  " stp ln rn. steps0 (Suc 0 + length t_wcode_main_first_part div 2, Bk # Bk # ires, Oc(Suc rs) @ Bk(n))
     (t_wcode_main_first_part @ shift t_twice (length t_wcode_main_first_part div 2) @
      ([(L, 1), (L, 1)] @ shift t_fourtimes (t_twice_len + 13) @ [(L, 1), (L, 1)])) stp 
    = (Suc (t_twice_len) + length t_wcode_main_first_part div 2, Bk(ln) @ Bk # Bk # ires, Oc(Suc (2 * rs)) @ Bk(rn))"
  using t_twice_change_term_state[of ires rs n]
  apply(erule_tac exE)
  apply(erule_tac exE)
  apply(erule_tac exE)
  apply(drule_tac t_twice_append_pre)
  apply(rename_tac stp ln rn)
  apply(rule_tac x = stp in exI, rule_tac x = ln in exI, rule_tac x = rn in exI)
  apply(simp)
  done

lemma mopup_mod2: "length (mopup k) mod 2  = 0"
  by(auto simp: mopup.simps)

lemma fetch_t_wcode_main_Oc[simp]: "fetch t_wcode_main (Suc (t_twice_len + length t_wcode_main_first_part div 2)) Oc
     = (L, Suc 0)"
  apply(subgoal_tac "length (t_twice) mod 2 = 0")
   apply(simp add: t_wcode_main_def nth_append fetch.simps t_wcode_main_first_part_def 
      nth_of.simps t_twice_len_def, auto)
  apply(simp add: t_twice_def t_twice_compile_def)
  using mopup_mod2[of 1]
  apply(simp)
  done

lemma wcode_jump1: 
  " stp ln rn. steps0 (Suc (t_twice_len) + length t_wcode_main_first_part div 2,
                       Bk(m) @ Bk # Bk # ires, Oc(Suc (2 * rs)) @ Bk(n))
     t_wcode_main stp 
    = (Suc 0, Bk(ln) @ Bk # ires, Bk # Oc(Suc (2 * rs)) @ Bk(rn))"
  apply(rule_tac x = "Suc 0" in exI, rule_tac x = "m" in exI, rule_tac x = n in exI)
  apply(simp add: steps.simps step.simps exp_ind)
  apply(case_tac m, simp_all)
  apply(simp add: exp_ind[THEN sym])
  done

lemma wcode_main_first_part_len[simp]:
  "length t_wcode_main_first_part = 24"
  apply(simp add: t_wcode_main_first_part_def)
  done

lemma wcode_double_case: 
  shows "stp ln rn. steps0 (Suc 0, Bk # Bk(m) @ Oc # Oc # ires, Bk # Oc(Suc rs) @ Bk(n)) t_wcode_main stp =
          (Suc 0, Bk # Bk(ln) @ Oc # ires, Bk # Oc(Suc (2 * rs + 2)) @ Bk(rn))"
    (is "stp ln rn. ?tm stp ln rn")
proof -
  from wcode_double_case_first_correctness[of ires rs m n] obtain na ln rn where
    "steps0 (Suc 0, Bk # Bk  m @ Oc # Oc # ires, Bk # Oc # Oc  rs @ Bk  n) t_wcode_main na
      = (13, Bk # Bk # Bk  ln @ Oc # ires, Oc # Oc # Oc  rs @ Bk  rn)"
    by(auto simp: wcode_double_case_inv.simps wcode_before_double.simps)
  hence "stp ln rn. steps0 (Suc 0, Bk # Bk(m) @ Oc # Oc # ires, Bk # Oc(Suc rs) @ Bk(n)) t_wcode_main stp =
          (13,  Bk # Bk # Bk(ln) @ Oc # ires, Oc(Suc (Suc rs)) @ Bk(rn))"
    by(case_tac "steps0 (Suc 0, Bk # Bk(m) @ Oc # Oc # ires, 
           Bk # Oc(Suc rs) @ Bk(n)) t_wcode_main na", auto)  
  from this obtain stpa lna rna where stp1: 
    "steps0 (Suc 0, Bk # Bk(m) @ Oc # Oc # ires, Bk # Oc(Suc rs) @ Bk(n)) t_wcode_main stpa = 
    (13, Bk # Bk # Bk(lna) @ Oc # ires, Oc(Suc (Suc rs)) @ Bk(rna))" by blast
  from t_twice_append[of "Bk(lna) @ Oc # ires" "Suc rs" rna] obtain stp ln rn
    where "steps0 (Suc 0 + length t_wcode_main_first_part div 2,
                   Bk # Bk # Bk  lna @ Oc # ires, Oc  Suc (Suc rs) @ Bk  rna)
                  (t_wcode_main_first_part @ shift t_twice (length t_wcode_main_first_part div 2) @
                   [(L, 1), (L, 1)] @ shift t_fourtimes (t_twice_len + 13) @ [(L, 1), (L, 1)]) stp =
           (Suc t_twice_len + length t_wcode_main_first_part div 2, 
            Bk  ln @ Bk # Bk # Bk  lna @ Oc # ires, Oc  Suc (2 * Suc rs) @ Bk  rn)" by blast
  hence " stp ln rn. steps0 (13, Bk # Bk # Bk(lna) @ Oc # ires, Oc(Suc (Suc rs)) @ Bk(rna)) t_wcode_main stp =
    (13 + t_twice_len, Bk # Bk # Bk(ln) @ Oc # ires, Oc(Suc (Suc (Suc (2 *rs)))) @ Bk(rn))"
    using t_twice_append[of "Bk(lna) @ Oc # ires" "Suc rs" rna]
    apply(simp)
    apply(rule_tac x = stp in exI, rule_tac x = "ln + lna" in exI, 
        rule_tac x = rn in exI)
    apply(simp add: t_wcode_main_def)
    apply(simp add: replicate_Suc[THEN sym] replicate_add [THEN sym] del: replicate_Suc)
    done
  from this obtain stpb lnb rnb where stp2: 
    "steps0 (13, Bk # Bk # Bk(lna) @ Oc # ires, Oc(Suc (Suc rs)) @ Bk(rna)) t_wcode_main stpb =
    (13 + t_twice_len, Bk # Bk # Bk(lnb) @ Oc # ires, Oc(Suc (Suc (Suc (2 *rs)))) @ Bk(rnb))" by blast
  from wcode_jump1[of lnb "Oc # ires" "Suc rs" rnb] obtain stp ln rn where
    "steps0 (Suc t_twice_len + length t_wcode_main_first_part div 2, 
             Bk  lnb @ Bk # Bk # Oc # ires, Oc  Suc (2 * Suc rs) @ Bk  rnb) t_wcode_main stp =
     (Suc 0, Bk  ln @ Bk # Oc # ires, Bk # Oc  Suc (2 * Suc rs) @ Bk  rn)" by metis
  hence "steps0 (13 + t_twice_len, Bk # Bk # Bk(lnb) @ Oc # ires,
    Oc(Suc (Suc (Suc (2 *rs)))) @ Bk(rnb)) t_wcode_main stp = 
       (Suc 0,  Bk # Bk(ln) @ Oc # ires, Bk # Oc(Suc (Suc (Suc (2 *rs)))) @ Bk(rn))"
    apply(auto simp add: t_wcode_main_def)
    apply(subgoal_tac "Bk(lnb) @ Bk # Bk # Oc # ires = Bk # Bk # Bk(lnb) @ Oc # ires", simp)
     apply(simp add: replicate_Suc[THEN sym] exp_ind[THEN sym] del: replicate_Suc)
    apply(simp)
    apply(simp add: replicate_Suc[THEN sym] exp_ind del: replicate_Suc)
    done 
  hence "stp ln rn. steps0 (13 + t_twice_len, Bk # Bk # Bk(lnb) @ Oc # ires,
    Oc(Suc (Suc (Suc (2 *rs)))) @ Bk(rnb)) t_wcode_main stp = 
       (Suc 0,  Bk # Bk(ln) @ Oc # ires, Bk # Oc(Suc (Suc (Suc (2 *rs)))) @ Bk(rn))"
    by blast
  from this obtain stpc lnc rnc where stp3: 
    "steps0 (13 + t_twice_len, Bk # Bk # Bk(lnb) @ Oc # ires,
    Oc(Suc (Suc (Suc (2 *rs)))) @ Bk(rnb)) t_wcode_main stpc = 
       (Suc 0,  Bk # Bk(lnc) @ Oc # ires, Bk # Oc(Suc (Suc (Suc (2 *rs)))) @ Bk(rnc))"
    by blast
  from stp1 stp2 stp3 have "?tm (stpa + stpb + stpc) lnc rnc" by simp
  thus "?thesis" by blast
qed


(* Begin: fourtime_case*)
fun wcode_on_left_moving_2_B :: "bin_inv_t"
  where
    "wcode_on_left_moving_2_B ires rs (l, r) =
     ( ml mr rn. l = Bk(ml) @ Oc # Bk # Oc # ires 
                 r = Bk(mr) @ Oc(Suc rs) @ Bk(rn)  
                 ml + mr > Suc 0  mr > 0)"

fun wcode_on_left_moving_2_O :: "bin_inv_t"
  where
    "wcode_on_left_moving_2_O ires rs (l, r) =
     ( ln rn. l = Bk # Oc # ires 
               r = Oc # Bk(ln) @ Bk # Bk # Oc(Suc rs) @ Bk(rn))"

fun wcode_on_left_moving_2 :: "bin_inv_t"
  where
    "wcode_on_left_moving_2 ires rs (l, r) = 
      (wcode_on_left_moving_2_B ires rs (l, r)  
      wcode_on_left_moving_2_O ires rs (l, r))"

fun wcode_on_checking_2 :: "bin_inv_t"
  where
    "wcode_on_checking_2 ires rs (l, r) =
       ( ln rn. l = Oc#ires  
                 r = Bk # Oc # Bk(ln) @ Bk # Bk # Oc(Suc rs) @ Bk(rn))"

fun wcode_goon_checking :: "bin_inv_t"
  where
    "wcode_goon_checking ires rs (l, r) =
       ( ln rn. l = ires 
                 r = Oc # Bk # Oc # Bk(ln) @ Bk # Bk # Oc(Suc rs) @ Bk(rn))"

fun wcode_right_move :: "bin_inv_t"
  where
    "wcode_right_move ires rs (l, r) = 
     ( ln rn. l = Oc # ires 
                 r = Bk # Oc # Bk(ln) @ Bk # Bk # Oc(Suc rs) @ Bk(rn))"

fun wcode_erase2 :: "bin_inv_t"
  where
    "wcode_erase2 ires rs (l, r) = 
        ( ln rn. l = Bk # Oc # ires 
                 tl r = Bk(ln) @ Bk # Bk # Oc(Suc rs) @ Bk(rn))"

fun wcode_on_right_moving_2 :: "bin_inv_t"
  where
    "wcode_on_right_moving_2 ires rs (l, r) = 
        ( ml mr rn. l = Bk(ml) @ Oc # ires  
                     r = Bk(mr) @ Oc(Suc rs) @ Bk(rn)  ml + mr > Suc 0)"

fun wcode_goon_right_moving_2 :: "bin_inv_t"
  where
    "wcode_goon_right_moving_2 ires rs (l, r) = 
        ( ml mr ln rn. l = Oc(ml) @ Bk # Bk # Bk(ln) @ Oc # ires 
                        r = Oc(mr) @ Bk(rn)  ml + mr = Suc rs)"

fun wcode_backto_standard_pos_2_B :: "bin_inv_t"
  where
    "wcode_backto_standard_pos_2_B ires rs (l, r) = 
           ( ln rn. l = Bk # Bk(ln) @ Oc # ires  
                     r = Bk # Oc(Suc (Suc rs)) @ Bk(rn))"

fun wcode_backto_standard_pos_2_O :: "bin_inv_t"
  where
    "wcode_backto_standard_pos_2_O ires rs (l, r) = 
          ( ml mr ln rn. l = Oc(ml )@ Bk # Bk # Bk(ln) @ Oc # ires  
                          r = Oc(mr) @ Bk(rn)  
                          ml + mr = (Suc (Suc rs))  mr > 0)"

fun wcode_backto_standard_pos_2 :: "bin_inv_t"
  where
    "wcode_backto_standard_pos_2 ires rs (l, r) = 
           (wcode_backto_standard_pos_2_O ires rs (l, r)  
           wcode_backto_standard_pos_2_B ires rs (l, r))"

fun wcode_before_fourtimes :: "bin_inv_t"
  where
    "wcode_before_fourtimes ires rs (l, r) = 
          ( ln rn. l = Bk # Bk # Bk(ln) @ Oc # ires  
                    r = Oc(Suc (Suc rs)) @ Bk(rn))"

declare wcode_on_left_moving_2_B.simps[simp del] wcode_on_left_moving_2.simps[simp del]
  wcode_on_left_moving_2_O.simps[simp del] wcode_on_checking_2.simps[simp del]
  wcode_goon_checking.simps[simp del] wcode_right_move.simps[simp del]
  wcode_erase2.simps[simp del]
  wcode_on_right_moving_2.simps[simp del] wcode_goon_right_moving_2.simps[simp del]
  wcode_backto_standard_pos_2_B.simps[simp del] wcode_backto_standard_pos_2_O.simps[simp del]
  wcode_backto_standard_pos_2.simps[simp del]

lemmas wcode_fourtimes_invs = 
  wcode_on_left_moving_2_B.simps wcode_on_left_moving_2.simps
  wcode_on_left_moving_2_O.simps wcode_on_checking_2.simps
  wcode_goon_checking.simps wcode_right_move.simps
  wcode_erase2.simps
  wcode_on_right_moving_2.simps wcode_goon_right_moving_2.simps
  wcode_backto_standard_pos_2_B.simps wcode_backto_standard_pos_2_O.simps
  wcode_backto_standard_pos_2.simps

fun wcode_fourtimes_case_inv :: "nat  bin_inv_t"
  where
    "wcode_fourtimes_case_inv st ires rs (l, r) = 
           (if st = Suc 0 then wcode_on_left_moving_2 ires rs (l, r)
            else if st = Suc (Suc 0) then wcode_on_checking_2 ires rs (l, r)
            else if st = 7 then wcode_goon_checking ires rs (l, r)
            else if st = 8 then wcode_right_move ires rs (l, r)
            else if st = 9 then wcode_erase2 ires rs (l, r)
            else if st = 10 then wcode_on_right_moving_2 ires rs (l, r)
            else if st = 11 then wcode_goon_right_moving_2 ires rs (l, r)
            else if st = 12 then wcode_backto_standard_pos_2 ires rs (l, r)
            else if st = t_twice_len + 14 then wcode_before_fourtimes ires rs (l, r)
            else False)"

declare wcode_fourtimes_case_inv.simps[simp del]

fun wcode_fourtimes_case_state :: "config  nat"
  where
    "wcode_fourtimes_case_state (st, l, r) = 13 - st"

fun wcode_fourtimes_case_step :: "config  nat"
  where
    "wcode_fourtimes_case_step (st, l, r) = 
         (if st = Suc 0 then length l
          else if st = 9 then 
           (if hd r = Oc then 1
            else 0)
          else if st = 10 then length r
          else if st = 11 then length r
          else if st = 12 then length l
          else 0)"

fun wcode_fourtimes_case_measure :: "config  nat × nat"
  where
    "wcode_fourtimes_case_measure (st, l, r) = 
     (wcode_fourtimes_case_state (st, l, r), 
      wcode_fourtimes_case_step (st, l, r))"

definition wcode_fourtimes_case_le :: "(config × config) set"
  where "wcode_fourtimes_case_le  (inv_image lex_pair wcode_fourtimes_case_measure)"

lemma wf_wcode_fourtimes_case_le[intro]: "wf wcode_fourtimes_case_le"
  by(auto simp: wcode_fourtimes_case_le_def)

lemma nonempty_snd [simp]:
  "wcode_on_left_moving_2 ires rs (b, []) = False"
  "wcode_on_checking_2 ires rs (b, []) = False"
  "wcode_goon_checking ires rs (b, []) = False"
  "wcode_right_move ires rs (b, []) = False"
  "wcode_erase2 ires rs (b, []) = False"
  "wcode_on_right_moving_2 ires rs (b, []) = False"
  "wcode_backto_standard_pos_2 ires rs (b, []) = False"
  "wcode_on_checking_2 ires rs (b, Oc # list) = False"
  by(auto simp: wcode_fourtimes_invs) 

lemma wcode_on_left_moving_2[simp]:
  "wcode_on_left_moving_2 ires rs (b, Bk # list)   wcode_on_left_moving_2 ires rs (tl b, hd b # Bk # list)"
  apply(simp only: wcode_fourtimes_invs)
  apply(erule_tac disjE)
   apply(erule_tac exE)+
   apply(simp add: gr1_conv_Suc exp_ind replicate_app_Cons_same split:hd_repeat_cases)
   apply (auto simp add: gr0_conv_Suc[symmetric] replicate_app_Cons_same split:hd_repeat_cases)
  by force+


lemma wcode_goon_checking_via_2 [simp]: "wcode_on_checking_2 ires rs (b, Bk # list)
          wcode_goon_checking ires rs (tl b, hd b # Bk # list)"
  unfolding wcode_fourtimes_invs by auto

lemma wcode_erase2_via_move [simp]: "wcode_right_move ires rs (b, Bk # list)   wcode_erase2 ires rs (Bk # b, list)"
  by (auto simp:wcode_fourtimes_invs ) auto

lemma wcode_on_right_moving_2_via_erase2[simp]:
  "wcode_erase2 ires rs (b, Bk # list)  wcode_on_right_moving_2 ires rs (Bk # b, list)"
  apply(auto simp:wcode_fourtimes_invs )
  apply(rule_tac x = "Suc (Suc 0)" in exI, simp add: exp_ind)
  by (metis replicate_Suc_iff_anywhere replicate_app_Cons_same)

lemma wcode_on_right_moving_2_move_Bk[simp]: "wcode_on_right_moving_2 ires rs (b, Bk # list)
        wcode_on_right_moving_2 ires rs (Bk # b, list)"
  apply(auto simp: wcode_fourtimes_invs) apply(rename_tac ml mr rn)
  apply(rule_tac x = "Suc ml" in exI, simp)
  apply(rule_tac x = "mr - 1" in exI, case_tac mr,auto)
  done

lemma wcode_backto_standard_pos_2_via_right[simp]:
  "wcode_goon_right_moving_2 ires rs (b, Bk # list)  
                 wcode_backto_standard_pos_2 ires rs (b, Oc # list)"
  apply(simp add: wcode_fourtimes_invs, auto)
  by (metis add.right_neutral add_Suc_shift append_Cons list.sel(3)
      replicate.simps(1) replicate_Suc replicate_Suc_iff_anywhere self_append_conv2
      tl_replicate zero_less_Suc)

lemma wcode_on_checking_2_via_left[simp]: "wcode_on_left_moving_2 ires rs (b, Oc # list)  
                     wcode_on_checking_2 ires rs (tl b, hd b # Oc # list)"
  by(auto simp: wcode_fourtimes_invs)

lemma wcode_backto_standard_pos_2_empty_via_right[simp]:
  "wcode_goon_right_moving_2 ires rs (b, []) 
              wcode_backto_standard_pos_2 ires rs (b, [Oc])"
  by (auto simp add: wcode_fourtimes_invs) force

lemma wcode_goon_checking_cases[simp]: "wcode_goon_checking ires rs (b, Oc # list) 
  (b = []  wcode_right_move ires rs ([Oc], list)) 
  (b  []  wcode_right_move ires rs (Oc # b, list))"
  apply(simp only: wcode_fourtimes_invs)
  apply(erule_tac exE)+
  apply(auto)
  done

lemma wcode_right_move_no_Oc[simp]: "wcode_right_move ires rs (b, Oc # list) = False"
  apply(auto simp: wcode_fourtimes_invs)
  done

lemma wcode_erase2_Bk_via_Oc[simp]: "wcode_erase2 ires rs (b, Oc # list)
        wcode_erase2 ires rs (b, Bk # list)"
  apply(auto simp: wcode_fourtimes_invs)
  done

lemma wcode_goon_right_moving_2_Oc_move[simp]:
  "wcode_on_right_moving_2 ires rs (b, Oc # list)
        wcode_goon_right_moving_2 ires rs (Oc # b, list)"
  apply(auto simp: wcode_fourtimes_invs)
  apply(rule_tac x = "Suc 0" in exI, auto)
  apply(rule_tac x = "ml - 2" in exI)
  apply(case_tac ml, simp, case_tac "ml - 1", simp_all)
  done

lemma wcode_backto_standard_pos_2_exists[simp]: "wcode_backto_standard_pos_2 ires rs (b, Bk # list)
        (ln. b = Bk # Bk(ln) @ Oc # ires)  (rn. list = Oc(Suc (Suc rs)) @ Bk(rn))"
  by(simp add: wcode_fourtimes_invs)

lemma wcode_goon_right_moving_2_move_Oc[simp]: "wcode_goon_right_moving_2 ires rs (b, Oc # list) 
       wcode_goon_right_moving_2 ires rs (Oc # b, list)"
  apply(simp only:wcode_fourtimes_invs, auto)
  apply(rename_tac ml ln mr rn)
  apply(case_tac mr;force)
  done


lemma wcode_backto_standard_pos_2_Oc_mv_hd[simp]:
  "wcode_backto_standard_pos_2 ires rs (b, Oc # list)    
             wcode_backto_standard_pos_2 ires rs (tl b, hd b # Oc # list)"
  apply(simp only: wcode_fourtimes_invs)
  apply(erule_tac disjE)
   apply(erule_tac exE)+ apply(rename_tac ml mr ln rn)
  by (case_tac ml, force,force,force)

lemma nonempty_fst[simp]:
  "wcode_on_left_moving_2 ires rs (b, Bk # list)  b  []"
  "wcode_on_checking_2 ires rs (b, Bk # list)  b  []"
  "wcode_goon_checking ires rs (b, Bk # list) = False"
  "wcode_right_move ires rs (b, Bk # list)  b []" 
  "wcode_erase2 ires rs (b, Bk # list)  b  []"
  "wcode_on_right_moving_2 ires rs (b, Bk # list)  b  []"
  "wcode_goon_right_moving_2 ires rs (b, Bk # list)  b  []"
  "wcode_backto_standard_pos_2 ires rs (b, Bk # list)   b  []"
  "wcode_on_left_moving_2 ires rs (b, Oc # list)  b  []"
  "wcode_goon_right_moving_2 ires rs (b, [])  b  []"
  "wcode_erase2 ires rs (b, Oc # list)  b  []"
  "wcode_on_right_moving_2 ires rs (b, Oc # list)  b  []"
  "wcode_goon_right_moving_2 ires rs (b, Oc # list)  b  []"
  "wcode_backto_standard_pos_2 ires rs (b, Oc # list)  b  []"
  by(auto simp: wcode_fourtimes_invs)


lemma wcode_fourtimes_case_first_correctness:
  shows "let P = (λ (st, l, r). st = t_twice_len + 14) in 
  let Q = (λ (st, l, r). wcode_fourtimes_case_inv st ires rs (l, r)) in 
  let f = (λ stp. steps0 (Suc 0, Bk # Bk(m) @ Oc # Bk # Oc # ires, Bk # Oc(Suc rs) @ Bk(n)) t_wcode_main stp) in
   n .P (f n)  Q (f (n::nat))"
proof -
  let ?P = "(λ (st, l, r). st = t_twice_len + 14)"
  let ?Q = "(λ (st, l, r). wcode_fourtimes_case_inv st ires rs (l, r))"
  let ?f = "(λ stp. steps0 (Suc 0, Bk # Bk(m) @ Oc # Bk # Oc # ires, Bk # Oc(Suc rs) @ Bk(n)) t_wcode_main stp)"
  have " n . ?P (?f n)  ?Q (?f (n::nat))"
  proof(rule_tac halt_lemma2)
    show "wf wcode_fourtimes_case_le"
      by auto
  next
    have "¬ ?P (?f na)  ?Q (?f na) 
                  ?Q (?f (Suc na))  (?f (Suc na), ?f na)  wcode_fourtimes_case_le" for na
      apply(cases "?f na", rule_tac impI)
      apply(simp add: step_red step.simps)
      apply(case_tac "snd (snd (?f na))", simp, case_tac [2] "hd (snd (snd (?f na)))", simp_all)
        apply(simp_all add: wcode_fourtimes_case_inv.simps
          wcode_fourtimes_case_le_def lex_pair_def split: if_splits)
      by(auto simp: wcode_backto_standard_pos_2.simps wcode_backto_standard_pos_2_O.simps
          wcode_backto_standard_pos_2_B.simps gr0_conv_Suc)
    thus " na. ¬ ?P (?f na)  ?Q (?f na) 
                  ?Q (?f (Suc na))  (?f (Suc na), ?f na)  wcode_fourtimes_case_le" by auto
  next
    show "?Q (?f 0)"
      apply(simp add: steps.simps wcode_fourtimes_case_inv.simps)
      apply(simp add: wcode_on_left_moving_2.simps wcode_on_left_moving_2_B.simps 
          wcode_on_left_moving_2_O.simps)
      apply(rule_tac x = "Suc m" in exI, simp )
      apply(rule_tac x ="Suc 0" in exI, auto)
      done
  next
    show "¬ ?P (?f 0)"
      apply(simp add: steps.simps)
      done
  qed
  thus "?thesis"
    apply(erule_tac exE, simp)
    done
qed

definition t_fourtimes_len :: "nat"
  where
    "t_fourtimes_len = (length t_fourtimes div 2)"

lemma primerec_rec_fourtimes_1[intro]: "primerec rec_fourtimes (Suc 0)"
  apply(auto simp: rec_fourtimes_def numeral_4_eq_4 constn.simps)
  by auto

lemma fourtimes_lemma: "rec_exec rec_fourtimes [rs] = 4 * rs"
  by(simp add: rec_exec.simps rec_fourtimes_def)

lemma t_fourtimes_correct: 
  "stp ln rn. steps0 (Suc 0, Bk # Bk # ires, Oc(Suc rs) @ Bk(n)) 
    (tm_of abc_fourtimes @ shift (mopup 1) (length (tm_of abc_fourtimes) div 2)) stp =
       (0, Bk(ln) @ Bk # Bk # ires, Oc(Suc (4 * rs)) @ Bk(rn))"
proof(case_tac "rec_ci rec_fourtimes")
  fix a b c
  assume h: "rec_ci rec_fourtimes = (a, b, c)"
  have "stp m l. steps0 (Suc 0, Bk # Bk # ires, <[rs]> @ Bk(n)) (tm_of abc_fourtimes @ shift (mopup (length [rs])) 
    (length (tm_of abc_fourtimes) div 2)) stp = (0, Bk(m) @ Bk # Bk # ires, Oc(Suc (rec_exec rec_fourtimes [rs])) @ Bk(l))"
    thm recursive_compile_to_tm_correct1
  proof(rule_tac recursive_compile_to_tm_correct1)
    show "rec_ci rec_fourtimes = (a, b, c)" by (simp add: h)
  next
    show "terminate rec_fourtimes [rs]"
      apply(rule_tac primerec_terminate)
      by auto
  next
    show "tm_of abc_fourtimes = tm_of (a [+] dummy_abc (length [rs]))"
      using h
      by(simp add: abc_fourtimes_def)
  qed
  thus "?thesis"
    apply(simp add: tape_of_list_def tape_of_nat_def fourtimes_lemma)
    done
qed

lemma wf_fourtimes[intro]: "tm_wf (t_fourtimes_compile, 0)"
  apply(simp only: t_fourtimes_compile_def)
  apply(rule_tac wf_tm_from_abacus, simp)
  done

lemma t_fourtimes_change_term_state:
  " stp ln rn. steps0 (Suc 0, Bk # Bk # ires, Oc(Suc rs) @ Bk(n)) t_fourtimes stp
     = (Suc t_fourtimes_len, Bk(ln) @ Bk # Bk # ires, Oc(Suc (4 * rs)) @ Bk(rn))"
proof -
  have "stp ln rn. steps0 (Suc 0, Bk # Bk # ires, Oc(Suc rs) @ Bk(n)) 
    (tm_of abc_fourtimes @ shift (mopup 1) ((length (tm_of abc_fourtimes) div 2))) stp =
    (0, Bk(ln) @ Bk # Bk # ires, Oc(Suc (4 * rs)) @ Bk(rn))"
    by(rule_tac t_fourtimes_correct)
  then obtain stp ln rn where 
    "steps0 (Suc 0, Bk # Bk # ires, Oc(Suc rs) @ Bk(n)) 
    (tm_of abc_fourtimes @ shift (mopup 1) ((length (tm_of abc_fourtimes) div 2))) stp =
    (0, Bk(ln) @ Bk # Bk # ires, Oc(Suc (4 * rs)) @ Bk(rn))" by blast
  hence " stp. steps0 (Suc 0, Bk # Bk # ires, Oc(Suc rs) @ Bk(n))
    (adjust0 t_fourtimes_compile) stp
     = (Suc (length t_fourtimes_compile div 2), Bk(ln) @ Bk # Bk # ires, Oc(Suc (4 * rs)) @ Bk(rn))"
    apply(rule_tac stp = stp in adjust_halt_eq)
     apply(simp add: t_fourtimes_compile_def, auto)
    done
  then obtain stpb where 
    "steps0 (Suc 0, Bk # Bk # ires, Oc(Suc rs) @ Bk(n))
    (adjust0 t_fourtimes_compile) stpb
     = (Suc (length t_fourtimes_compile div 2), Bk(ln) @ Bk # Bk # ires, Oc(Suc (4 * rs)) @ Bk(rn))" ..
  thus "?thesis"
    apply(simp add: t_fourtimes_def t_fourtimes_len_def)
    by metis
qed

lemma length_t_twice_even[intro]: "is_even (length t_twice)"
  by(auto simp: t_twice_def t_twice_compile_def intro!:mopup_mod2)

lemma t_fourtimes_append_pre:
  "steps0 (Suc 0, Bk # Bk # ires, Oc(Suc rs) @ Bk(n)) t_fourtimes stp
  = (Suc t_fourtimes_len, Bk(ln) @ Bk # Bk # ires, Oc(Suc (4 * rs)) @ Bk(rn))
    steps0 (Suc 0 + length (t_wcode_main_first_part @ 
              shift t_twice (length t_wcode_main_first_part div 2) @ [(L, 1), (L, 1)]) div 2,
       Bk # Bk # ires, Oc(Suc rs) @ Bk(n))
     ((t_wcode_main_first_part @ 
  shift t_twice (length t_wcode_main_first_part div 2) @ [(L, 1), (L, 1)]) @ 
  shift t_fourtimes (length (t_wcode_main_first_part @ 
  shift t_twice (length t_wcode_main_first_part div 2) @ [(L, 1), (L, 1)]) div 2) @ ([(L, 1), (L, 1)])) stp 
  = ((Suc t_fourtimes_len) + length (t_wcode_main_first_part @ 
  shift t_twice (length t_wcode_main_first_part div 2) @ [(L, 1), (L, 1)]) div 2,
  Bk(ln) @ Bk # Bk # ires, Oc(Suc (4 * rs)) @ Bk(rn))"
  using length_t_twice_even
  by(intro tm_append_shift_append_steps, auto)

lemma split_26_even[simp]: "(26 + l::nat) div 2 = l div 2 + 13" by(simp)

lemma t_twice_len_plust_14[simp]: "t_twice_len + 14 =  14 + length (shift t_twice 12) div 2"
  apply(simp add: t_twice_def t_twice_len_def)
  done

lemma t_fourtimes_append:
  " stp ln rn. 
  steps0 (Suc 0 + length (t_wcode_main_first_part @ shift t_twice
  (length t_wcode_main_first_part div 2) @ [(L, 1), (L, 1)]) div 2, 
  Bk # Bk # ires, Oc(Suc rs) @ Bk(n))
  ((t_wcode_main_first_part @ shift t_twice (length t_wcode_main_first_part div 2) @
  [(L, 1), (L, 1)]) @ shift t_fourtimes (t_twice_len + 13) @ [(L, 1), (L, 1)]) stp 
  = (Suc t_fourtimes_len + length (t_wcode_main_first_part @ shift t_twice
  (length t_wcode_main_first_part div 2) @ [(L, 1), (L, 1)]) div 2, Bk(ln) @ Bk # Bk # ires,
                                                                 Oc(Suc (4 * rs)) @ Bk(rn))"
  using t_fourtimes_change_term_state[of ires rs n]
  apply(erule_tac exE)
  apply(erule_tac exE)
  apply(erule_tac exE)
  apply(drule_tac t_fourtimes_append_pre)
  apply(rule_tac x = stp in exI, rule_tac x = ln in exI, rule_tac x = rn in exI)
  apply(simp add: t_twice_len_def)
  done

lemma even_fourtimes_len: "length t_fourtimes mod 2 = 0"
  apply(auto simp: t_fourtimes_def t_fourtimes_compile_def)
  by (metis mopup_mod2)

lemma t_twice_even[simp]: "2 * (length t_twice div 2) = length t_twice"
  using length_t_twice_even by arith

lemma t_fourtimes_even[simp]: "2 * (length t_fourtimes div 2) = length t_fourtimes"
  using even_fourtimes_len
  by arith

lemma fetch_t_wcode_14_Oc: "fetch t_wcode_main (14 + length t_twice div 2 + t_fourtimes_len) Oc
             = (L, Suc 0)" 
  apply(subgoal_tac "14 = Suc 13")
   apply(simp only: fetch.simps add_Suc nth_of.simps t_wcode_main_def)
   apply(simp add:length_t_twice_even t_fourtimes_len_def nth_append)
  by arith

lemma fetch_t_wcode_14_Bk: "fetch t_wcode_main (14 + length t_twice div 2 + t_fourtimes_len) Bk
             = (L, Suc 0)"
  apply(subgoal_tac "14 = Suc 13")
   apply(simp only: fetch.simps add_Suc nth_of.simps t_wcode_main_def)
   apply(simp add:length_t_twice_even t_fourtimes_len_def nth_append)
  by arith

lemma fetch_t_wcode_14 [simp]: "fetch t_wcode_main (14 + length t_twice div 2 + t_fourtimes_len) b
             = (L, Suc 0)"
  apply(case_tac b, simp_all add:fetch_t_wcode_14_Bk fetch_t_wcode_14_Oc)
  done

lemma wcode_jump2: 
  " stp ln rn. steps0 (t_twice_len + 14 + t_fourtimes_len
  , Bk # Bk # Bk(lnb) @ Oc # ires, Oc(Suc (4 * rs + 4)) @ Bk(rnb)) t_wcode_main stp =
  (Suc 0, Bk # Bk(ln) @ Oc # ires, Bk # Oc(Suc (4 * rs + 4)) @ Bk(rn))"
  apply(rule_tac x = "Suc 0" in exI)
  apply(simp add: steps.simps)
  apply(rule_tac x = lnb in exI, rule_tac x = rnb in exI)
  apply(simp add: step.simps)
  done

lemma wcode_fourtimes_case:
  shows "stp ln rn.
  steps0 (Suc 0, Bk # Bk(m) @ Oc # Bk # Oc # ires, Bk # Oc(Suc rs) @ Bk(n)) t_wcode_main stp =
  (Suc 0, Bk # Bk(ln) @ Oc # ires, Bk # Oc(Suc (4*rs + 4)) @ Bk(rn))"
proof -
  have "stp ln rn.
  steps0 (Suc 0, Bk # Bk(m) @ Oc # Bk # Oc # ires, Bk # Oc(Suc rs) @ Bk(n)) t_wcode_main stp =
  (t_twice_len + 14, Bk # Bk # Bk(ln) @ Oc # ires, Oc(Suc (rs + 1)) @ Bk(rn))"
    using wcode_fourtimes_case_first_correctness[of ires rs m n]
    by (auto simp add: wcode_fourtimes_case_inv.simps) auto
  from this obtain stpa lna rna where stp1:
    "steps0 (Suc 0, Bk # Bk(m) @ Oc # Bk # Oc # ires, Bk # Oc(Suc rs) @ Bk(n)) t_wcode_main stpa =
  (t_twice_len + 14, Bk # Bk # Bk(lna) @ Oc # ires, Oc(Suc (rs + 1)) @ Bk(rna))" by blast
  have "stp ln rn. steps0 (t_twice_len + 14, Bk # Bk # Bk(lna) @ Oc # ires, Oc(Suc (rs + 1)) @ Bk(rna))
                     t_wcode_main stp =
          (t_twice_len + 14 + t_fourtimes_len, Bk # Bk # Bk(ln) @ Oc # ires,  Oc(Suc (4*rs + 4)) @ Bk(rn))"
    using t_fourtimes_append[of " Bk(lna) @ Oc # ires" "rs + 1" rna]
    apply(erule_tac exE)
    apply(erule_tac exE)
    apply(erule_tac exE)
    apply(simp add: t_wcode_main_def) apply(rename_tac stp ln rn)
    apply(rule_tac x = stp in exI, 
        rule_tac x = "ln + lna" in exI,
        rule_tac x = rn in exI, simp)
    apply(simp add: replicate_Suc[THEN sym] replicate_add[THEN sym] del: replicate_Suc)
    done
  from this obtain stpb lnb rnb where stp2:
    "steps0 (t_twice_len + 14, Bk # Bk # Bk(lna) @ Oc # ires, Oc(Suc (rs + 1)) @ Bk(rna))
                     t_wcode_main stpb =
       (t_twice_len + 14 + t_fourtimes_len, Bk # Bk # Bk(lnb) @ Oc # ires,  Oc(Suc (4*rs + 4)) @ Bk(rnb))"
    by blast
  have "stp ln rn. steps0 (t_twice_len + 14 + t_fourtimes_len,
    Bk # Bk # Bk(lnb) @ Oc # ires,  Oc(Suc (4*rs + 4)) @ Bk(rnb))
    t_wcode_main stp =
    (Suc 0, Bk # Bk(ln) @ Oc # ires, Bk # Oc(Suc (4*rs + 4)) @ Bk(rn))"
    apply(rule wcode_jump2)
    done
  from this obtain stpc lnc rnc where stp3: 
    "steps0 (t_twice_len + 14 + t_fourtimes_len,
    Bk # Bk # Bk(lnb) @ Oc # ires,  Oc(Suc (4*rs + 4)) @ Bk(rnb))
    t_wcode_main stpc =
    (Suc 0, Bk # Bk(lnc) @ Oc # ires, Bk # Oc(Suc (4*rs + 4)) @ Bk(rnc))"
    by blast
  from stp1 stp2 stp3 show "?thesis"
    apply(rule_tac x = "stpa + stpb + stpc" in exI,
        rule_tac x = lnc in exI, rule_tac x = rnc in exI)
    apply(simp)
    done
qed

fun wcode_on_left_moving_3_B :: "bin_inv_t"
  where
    "wcode_on_left_moving_3_B ires rs (l, r) = 
       ( ml mr rn. l = Bk(ml) @ Oc # Bk # Bk # ires 
                    r = Bk(mr) @ Oc(Suc rs) @ Bk(rn)  
                    ml + mr > Suc 0  mr > 0 )"

fun wcode_on_left_moving_3_O :: "bin_inv_t"
  where
    "wcode_on_left_moving_3_O ires rs (l, r) = 
         ( ln rn. l = Bk # Bk # ires 
                   r = Oc # Bk(ln) @ Bk # Bk # Oc(Suc rs) @ Bk(rn))"

fun wcode_on_left_moving_3 :: "bin_inv_t"
  where
    "wcode_on_left_moving_3 ires rs (l, r) = 
       (wcode_on_left_moving_3_B ires rs (l, r)   
        wcode_on_left_moving_3_O ires rs (l, r))"

fun wcode_on_checking_3 :: "bin_inv_t"
  where
    "wcode_on_checking_3 ires rs (l, r) = 
         ( ln rn. l = Bk # ires 
             r = Bk # Oc # Bk(ln) @ Bk # Bk # Oc(Suc rs) @ Bk(rn))"

fun wcode_goon_checking_3 :: "bin_inv_t"
  where
    "wcode_goon_checking_3 ires rs (l, r) = 
         ( ln rn. l = ires 
             r = Bk # Bk # Oc # Bk(ln) @ Bk # Bk # Oc(Suc rs) @ Bk(rn))"

fun wcode_stop :: "bin_inv_t"
  where
    "wcode_stop ires rs (l, r) = 
          ( ln rn. l = Bk # ires 
             r = Bk # Oc # Bk(ln) @ Bk # Bk # Oc(Suc rs) @ Bk(rn))"

fun wcode_halt_case_inv :: "nat  bin_inv_t"
  where
    "wcode_halt_case_inv st ires rs (l, r) = 
          (if st = 0 then wcode_stop ires rs (l, r)
           else if st = Suc 0 then wcode_on_left_moving_3 ires rs (l, r)
           else if st = Suc (Suc 0) then wcode_on_checking_3 ires rs (l, r)
           else if st = 7 then wcode_goon_checking_3 ires rs (l, r)
           else False)"

fun wcode_halt_case_state :: "config  nat"
  where
    "wcode_halt_case_state (st, l, r) = 
           (if st = 1 then 5
            else if st = Suc (Suc 0) then 4
            else if st = 7 then 3
            else 0)"

fun wcode_halt_case_step :: "config  nat"
  where
    "wcode_halt_case_step (st, l, r) = 
         (if st = 1 then length l
         else 0)"

fun wcode_halt_case_measure :: "config  nat × nat"
  where
    "wcode_halt_case_measure (st, l, r) = 
     (wcode_halt_case_state (st, l, r), 
      wcode_halt_case_step (st, l, r))"

definition wcode_halt_case_le :: "(config × config) set"
  where "wcode_halt_case_le  (inv_image lex_pair wcode_halt_case_measure)"

lemma wf_wcode_halt_case_le[intro]: "wf wcode_halt_case_le"
  by(auto simp: wcode_halt_case_le_def)

declare wcode_on_left_moving_3_B.simps[simp del] wcode_on_left_moving_3_O.simps[simp del]  
  wcode_on_checking_3.simps[simp del] wcode_goon_checking_3.simps[simp del] 
  wcode_on_left_moving_3.simps[simp del] wcode_stop.simps[simp del]

lemmas wcode_halt_invs = 
  wcode_on_left_moving_3_B.simps wcode_on_left_moving_3_O.simps
  wcode_on_checking_3.simps wcode_goon_checking_3.simps 
  wcode_on_left_moving_3.simps wcode_stop.simps


lemma wcode_on_left_moving_3_mv_Bk[simp]: "wcode_on_left_moving_3 ires rs (b, Bk # list)
  wcode_on_left_moving_3 ires rs (tl b, hd b # Bk # list)"
  apply(simp only: wcode_halt_invs)
  apply(erule_tac disjE)
   apply(erule_tac exE)+ apply(rename_tac ml mr rn)
   apply(case_tac ml, simp)
    apply(rule_tac x = "mr - 2" in exI, rule_tac x = rn in exI)
    apply(case_tac mr, force, simp add: exp_ind del: replicate_Suc)
    apply(case_tac "mr - 1", force, simp add: exp_ind del: replicate_Suc)
   apply force
  apply force
  done

lemma wcode_goon_checking_3_cases[simp]: "wcode_goon_checking_3 ires rs (b, Bk # list)  
  (b = []  wcode_stop ires rs ([Bk], list)) 
  (b  []  wcode_stop ires rs (Bk # b, list))"
  apply(auto simp: wcode_halt_invs)
  done

lemma wcode_on_checking_3_mv_Oc[simp]: "wcode_on_left_moving_3 ires rs (b, Oc # list)  
               wcode_on_checking_3 ires rs (tl b, hd b # Oc # list)"
  by(simp add:wcode_halt_invs)

lemma wcode_3_nonempty[simp]:
  "wcode_on_left_moving_3 ires rs (b, []) = False"
  "wcode_on_checking_3 ires rs (b, []) = False"
  "wcode_goon_checking_3 ires rs (b, []) = False"
  "wcode_on_left_moving_3 ires rs (b, Oc # list)  b  []"
  "wcode_on_checking_3 ires rs (b, Oc # list) = False"
  "wcode_on_left_moving_3 ires rs (b, Bk # list)  b  []"
  "wcode_on_checking_3 ires rs (b, Bk # list)  b  []"
  "wcode_goon_checking_3 ires rs (b, Oc # list) = False"
  by(auto simp: wcode_halt_invs)

lemma wcode_goon_checking_3_mv_Bk[simp]: "wcode_on_checking_3 ires rs (b, Bk # list)  
  wcode_goon_checking_3 ires rs (tl b, hd b # Bk # list)"
  apply(auto simp: wcode_halt_invs)
  done

lemma t_halt_case_correctness: 
  shows "let P = (λ (st, l, r). st = 0) in 
       let Q = (λ (st, l, r). wcode_halt_case_inv st ires rs (l, r)) in 
       let f = (λ stp. steps0 (Suc 0, Bk # Bk(m) @ Oc # Bk # Bk # ires, Bk # Oc(Suc rs) @ Bk(n)) t_wcode_main stp) in
        n .P (f n)  Q (f (n::nat))"
proof -
  let ?P = "(λ (st, l, r). st = 0)"
  let ?Q = "(λ (st, l, r). wcode_halt_case_inv st ires rs (l, r))"
  let ?f = "(λ stp. steps0 (Suc 0, Bk # Bk(m) @ Oc # Bk # Bk # ires, Bk # Oc(Suc rs) @ Bk(n)) t_wcode_main stp)"
  have " n. ?P (?f n)  ?Q (?f (n::nat))"
  proof(rule_tac halt_lemma2)
    show "wf wcode_halt_case_le" by auto
  next
    { fix na
      obtain a b c where abc:"?f na = (a,b,c)" by(cases "?f na",auto)
      hence "¬ ?P (?f na)  ?Q (?f na) 
                    ?Q (?f (Suc na))  (?f (Suc na), ?f na)  wcode_halt_case_le"
        apply(simp add: step.simps)
        apply(cases c;cases "hd c")
           apply(auto simp: wcode_halt_case_le_def lex_pair_def split: if_splits)
        done
    }
    thus " na. ¬ ?P (?f na)  ?Q (?f na)  
                    ?Q (?f (Suc na))  (?f (Suc na), ?f na)  wcode_halt_case_le" by blast     
  next 
    show "?Q (?f 0)"
      apply(simp add: steps.simps wcode_halt_invs)
      apply(rule_tac x = "Suc m" in exI, simp)
      apply(rule_tac x = "Suc 0" in exI, auto)
      done
  next
    show "¬ ?P (?f 0)"
      apply(simp add: steps.simps)
      done
  qed
  thus "?thesis"
    apply(auto)
    done
qed

declare wcode_halt_case_inv.simps[simp del]
lemma leading_Oc[intro]: " xs. (<rev list @ [aa::nat]> :: cell list) = Oc # xs"
  apply(case_tac "rev list", simp)
  apply(simp add: tape_of_nl_cons)
  done

lemma wcode_halt_case:
  "stp ln rn. steps0 (Suc 0, Bk # Bk(m) @ Oc # Bk # Bk # ires, Bk # Oc(Suc rs) @ Bk(n))
  t_wcode_main stp  = (0, Bk # ires, Bk # Oc # Bk(ln) @ Bk # Bk # Oc(Suc rs) @ Bk(rn))"
proof -
  let ?P = "λ(st, l, r). st = 0"
  let ?Q = "λ(st, l, r). wcode_halt_case_inv st ires rs (l, r)"
  let ?f = "steps0 (Suc 0, Bk # Bk  m @ Oc # Bk # Bk # ires, Bk # Oc  Suc rs @ Bk  n) t_wcode_main"
  from t_halt_case_correctness[of ires rs m n] obtain n where "?P (?f n)  ?Q (?f n)" by metis
  thus ?thesis
    apply(simp add: wcode_halt_case_inv.simps wcode_stop.simps)
    apply(case_tac "steps0 (Suc 0, Bk # Bk(m) @ Oc # Bk # Bk # ires,
                Bk # Oc(Suc rs) @ Bk(n)) t_wcode_main n")
    apply(auto simp: wcode_halt_case_inv.simps wcode_stop.simps)
    by auto
qed

lemma bl_bin_one[simp]: "bl_bin [Oc] = 1"
  apply(simp add: bl_bin.simps)
  done

lemma twice_power[intro]: "2 * 2 ^ a = Suc (Suc (2 * bl_bin (Oc  a)))"
  apply(induct a, auto simp: bl_bin.simps)
  done
declare replicate_Suc[simp del]

lemma t_wcode_main_lemma_pre:
  "args  []; lm = <args::nat list>  
        stp ln rn. steps0 (Suc 0, Bk # Bk(m) @ rev lm @ Bk # Bk # ires, Bk # Oc(Suc rs) @ Bk(n)) t_wcode_main
                    stp
      = (0, Bk # ires, Bk # Oc # Bk(ln) @ Bk # Bk # Oc(bl_bin lm + rs * 2^(length lm - 1) ) @ Bk(rn))"
proof(induct "length args" arbitrary: args lm rs m n, simp)
  fix x args lm rs m n
  assume ind:
    "args lm rs m n.
    x = length args; (args::nat list)  []; lm = <args>
     stp ln rn.
    steps0 (Suc 0, Bk # Bk(m) @ rev lm @ Bk # Bk # ires, Bk # Oc(Suc rs) @ Bk(n)) t_wcode_main stp =
    (0, Bk # ires, Bk # Oc # Bk(ln) @ Bk # Bk # Oc(bl_bin lm + rs * 2 ^ (length lm - 1)) @ Bk(rn))"
    and h: "Suc x = length args" "(args::nat list)  []" "lm = <args>"
  from h have " (a::nat) xs. args = xs @ [a]"
    apply(rule_tac x = "last args" in exI)
    apply(rule_tac x = "butlast args" in exI, auto)
    done    
  from this obtain a xs where "args = xs @ [a]" by blast
  from h and this show
    "stp ln rn.
    steps0 (Suc 0, Bk # Bk(m) @ rev lm @ Bk # Bk # ires, Bk # Oc(Suc rs) @ Bk(n)) t_wcode_main stp =
    (0, Bk # ires, Bk # Oc # Bk(ln) @ Bk # Bk # Oc(bl_bin lm + rs * 2 ^ (length lm - 1)) @ Bk(rn))"
  proof(case_tac "xs::nat list", simp)
    show "stp ln rn.
          steps0 (Suc 0, Bk # Bk  m @ Oc  Suc a @ Bk # Bk # ires, Bk # Oc  Suc rs @ Bk  n) t_wcode_main stp =
          (0, Bk # ires, Bk # Oc # Bk  ln @ Bk # Bk # Oc  (bl_bin (Oc  Suc a) + rs * 2 ^ a) @ Bk  rn)"
    proof(induct "a" arbitrary: m n rs ires, simp)
      fix m n rs ires
      show "stp ln rn.
          steps0 (Suc 0, Bk # Bk  m @ Oc # Bk # Bk # ires, Bk # Oc  Suc rs @ Bk  n) t_wcode_main stp =
          (0, Bk # ires, Bk # Oc # Bk  ln @ Bk # Bk # Oc  Suc rs @ Bk  rn)"
        apply(rule_tac wcode_halt_case)
        done
    next
      fix a m n rs ires
      assume ind2:
        "m n rs ires.
           stp ln rn.
              steps0 (Suc 0, Bk # Bk  m @ Oc  Suc a @ Bk # Bk # ires, Bk # Oc  Suc rs @ Bk  n) t_wcode_main stp =
              (0, Bk # ires, Bk # Oc # Bk  ln @ Bk # Bk # Oc  (bl_bin (Oc  Suc a) + rs * 2 ^ a) @ Bk  rn)"
      show " stp ln rn.
          steps0 (Suc 0, Bk # Bk  m @ Oc  Suc (Suc a) @ Bk # Bk # ires, Bk # Oc  Suc rs @ Bk  n) t_wcode_main stp =
          (0, Bk # ires, Bk # Oc # Bk  ln @ Bk # Bk # Oc  (bl_bin (Oc  Suc (Suc a)) + rs * 2 ^ Suc a) @ Bk  rn)"
      proof -
        have "stp ln rn.
          steps0 (Suc 0, Bk # Bk(m) @ rev (<Suc a>) @ Bk # Bk # ires, Bk # Oc(Suc rs) @ Bk(n)) t_wcode_main stp =
          (Suc 0, Bk # Bk(ln) @ rev (<a>) @ Bk # Bk # ires, Bk # Oc(Suc (2 * rs + 2)) @ Bk(rn))"
          apply(simp add: tape_of_nat)
          using wcode_double_case[of m "Oc(a) @ Bk # Bk # ires" rs n]
          apply(simp add: replicate_Suc)
          done
        from this obtain stpa lna rna where stp1:  
          "steps0 (Suc 0, Bk # Bk(m) @ rev (<Suc a>) @ Bk # Bk # ires, Bk # Oc(Suc rs) @ Bk(n)) t_wcode_main stpa =
          (Suc 0, Bk # Bk(lna) @ rev (<a>) @ Bk # Bk # ires, Bk # Oc(Suc (2 * rs + 2)) @ Bk(rna))" by blast
        moreover have 
          "stp ln rn.
          steps0 (Suc 0,  Bk # Bk(lna) @ rev (<a::nat>) @ Bk # Bk # ires, Bk # Oc(Suc (2 * rs + 2)) @ Bk(rna)) t_wcode_main stp =
          (0, Bk # ires, Bk # Oc # Bk(ln) @ Bk # Bk # Oc(bl_bin (<a>) + (2*rs + 2)  * 2 ^ a) @ Bk(rn))"
          using ind2[of lna ires "2*rs + 2" rna] by(simp add: tape_of_list_def tape_of_nat_def)   
        from this obtain stpb lnb rnb where stp2:  
          "steps0 (Suc 0,  Bk # Bk(lna) @ rev (<a>) @ Bk # Bk # ires, Bk # Oc(Suc (2 * rs + 2)) @ Bk(rna)) t_wcode_main stpb =
          (0, Bk # ires, Bk # Oc # Bk(lnb) @ Bk # Bk # Oc(bl_bin (<a>) + (2*rs + 2)  * 2 ^ a) @ Bk(rnb))"
          by blast
        from stp1 and stp2 show "?thesis"
          apply(rule_tac x = "stpa + stpb" in exI,
              rule_tac x = lnb in exI, rule_tac x = rnb in exI, simp add: tape_of_nat_def)
          apply(simp add:  bl_bin.simps replicate_Suc)
          apply(auto)
          done
      qed
    qed
  next
    fix aa list
    assume g: "Suc x = length args" "args  []" "lm = <args>" "args = xs @ [a::nat]" "xs = (aa::nat) # list"
    thus "stp ln rn. steps0 (Suc 0, Bk # Bk(m) @ rev lm @ Bk # Bk # ires, Bk # Oc(Suc rs) @ Bk(n)) t_wcode_main stp =
      (0, Bk # ires, Bk # Oc # Bk(ln) @ Bk # Bk # Oc(bl_bin lm + rs * 2 ^ (length lm - 1)) @ Bk(rn))"
    proof(induct a arbitrary: m n rs args lm, simp_all add: tape_of_nl_rev del: subst_all, 
        simp only: tape_of_nl_cons_app1, simp del: subst_all)
      fix m n rs args lm
      have "stp ln rn.
        steps0 (Suc 0, Bk # Bk(m) @ Oc # Bk # rev (<(aa::nat) # list>) @ Bk # Bk # ires,
        Bk # Oc(Suc rs) @ Bk(n)) t_wcode_main stp =
        (Suc 0, Bk # Bk(ln) @ rev (<aa # list>) @ Bk # Bk # ires, 
        Bk # Oc(Suc (4*rs + 4)) @ Bk(rn))"
      proof(simp add: tape_of_nl_rev)
        have " xs. (<rev list @ [aa]>) = Oc # xs" by auto           
        from this obtain xs where "(<rev list @ [aa]>) = Oc # xs" ..
        thus "stp ln rn.
            steps0 (Suc 0, Bk # Bk(m) @ Oc # Bk # <rev list @ [aa]> @ Bk # Bk # ires,
            Bk # Oc(Suc rs) @ Bk(n)) t_wcode_main stp =
            (Suc 0, Bk # Bk(ln) @ <rev list @ [aa]> @ Bk # Bk # ires, Bk # Oc(5 + 4 * rs) @ Bk(rn))"
          apply(simp)
          using wcode_fourtimes_case[of m "xs @ Bk # Bk # ires" rs n]
          apply(simp)
          done
      qed
      from this obtain stpa lna rna where stp1:
        "steps0 (Suc 0, Bk # Bk(m) @ Oc # Bk # rev (<aa # list>) @ Bk # Bk # ires,
        Bk # Oc(Suc rs) @ Bk(n)) t_wcode_main stpa =
        (Suc 0, Bk # Bk(lna) @ rev (<aa # list>) @ Bk # Bk # ires, 
        Bk # Oc(Suc (4*rs + 4)) @ Bk(rna))" by blast
      from g have 
        " stp ln rn. steps0 (Suc 0, Bk # Bk(lna) @ rev (<(aa::nat) # list>) @ Bk # Bk # ires, 
        Bk # Oc(Suc (4*rs + 4)) @ Bk(rna)) t_wcode_main stp = (0, Bk # ires, 
        Bk # Oc # Bk(ln) @ Bk # Bk # Oc(bl_bin (<aa#list>)+ (4*rs + 4) * 2^(length (<aa#list>) - 1) ) @ Bk(rn))"
        apply(rule_tac args = "(aa::nat)#list" in ind, simp_all)
        done
      from this obtain stpb lnb rnb where stp2:
        "steps0 (Suc 0, Bk # Bk(lna) @ rev (<(aa::nat) # list>) @ Bk # Bk # ires, 
         Bk # Oc(Suc (4*rs + 4)) @ Bk(rna)) t_wcode_main stpb = (0, Bk # ires, 
         Bk # Oc # Bk(lnb) @ Bk # Bk # Oc(bl_bin (<aa#list>)+ (4*rs + 4) * 2^(length (<aa#list>) - 1) ) @ Bk(rnb))"
        by blast
      from stp1 and stp2 and h
      show "stp ln rn.
         steps0 (Suc 0, Bk # Bk(m) @ Oc # Bk # <rev list @ [aa]> @ Bk # Bk # ires,
         Bk # Oc(Suc rs) @ Bk(n)) t_wcode_main stp =
         (0, Bk # ires, Bk # Oc # Bk(ln) @ Bk #
         Bk # Oc(bl_bin (Oc(Suc aa) @ Bk # <list @ [0]>) + rs * (2 * 2 ^ (aa + length (<list @ [0]>)))) @ Bk(rn))"
        apply(rule_tac x = "stpa + stpb" in exI, rule_tac x = lnb in exI,
            rule_tac x = rnb in exI, simp add: steps_add tape_of_nl_rev)
        done
    next
      fix ab m n rs args lm
      assume ind2:
        " m n rs args lm.
         lm = <aa # list @ [ab]>; args = aa # list @ [ab]
          stp ln rn.
         steps0 (Suc 0, Bk # Bk(m) @ <ab # rev list @ [aa]> @ Bk # Bk # ires,
         Bk # Oc(Suc rs) @ Bk(n)) t_wcode_main stp =
         (0, Bk # ires, Bk # Oc # Bk(ln) @ Bk #
         Bk # Oc(bl_bin (<aa # list @ [ab]>) + rs * 2 ^ (length (<aa # list @ [ab]>) - Suc 0)) @ Bk(rn))"
        and k: "args = aa # list @ [Suc ab]" "lm = <aa # list @ [Suc ab]>"
      show "stp ln rn.
         steps0 (Suc 0, Bk # Bk(m) @ <Suc ab # rev list @ [aa]> @ Bk # Bk # ires,
         Bk # Oc(Suc rs) @ Bk(n)) t_wcode_main stp =
         (0, Bk # ires,Bk # Oc # Bk(ln) @ Bk # 
         Bk # Oc(bl_bin (<aa # list @ [Suc ab]>) + rs * 2 ^ (length (<aa # list @ [Suc ab]>) - Suc 0)) @ Bk(rn))"
      proof(simp add: tape_of_nl_cons_app1)
        have "stp ln rn.
           steps0 (Suc 0, Bk # Bk(m) @ Oc(Suc (Suc ab)) @ Bk # <rev list @ [aa]> @ Bk # Bk # ires, 
           Bk # Oc # Oc(rs) @ Bk(n)) t_wcode_main stp
           = (Suc 0, Bk # Bk(ln) @ Oc(Suc ab) @ Bk # <rev list @ [aa]> @ Bk # Bk # ires,
           Bk # Oc(Suc (2*rs + 2)) @ Bk(rn))"
          using wcode_double_case[of m "Oc(ab) @ Bk # <rev list @ [aa]> @ Bk # Bk # ires"
              rs n]
          apply(simp add: replicate_Suc)
          done
        from this obtain stpa lna rna where stp1:
          "steps0 (Suc 0, Bk # Bk(m) @ Oc(Suc (Suc ab)) @ Bk # <rev list @ [aa]> @ Bk # Bk # ires, 
           Bk # Oc # Oc(rs) @ Bk(n)) t_wcode_main stpa
           = (Suc 0, Bk # Bk(lna) @ Oc(Suc ab) @ Bk # <rev list @ [aa]> @ Bk # Bk # ires,
           Bk # Oc(Suc (2*rs + 2)) @ Bk(rna))" by blast
        from k have 
          " stp ln rn. steps0 (Suc 0, Bk # Bk(lna) @ <ab # rev list @ [aa]> @ Bk # Bk # ires,
           Bk # Oc(Suc (2*rs + 2)) @ Bk(rna)) t_wcode_main stp
           = (0, Bk # ires, Bk # Oc # Bk(ln) @ Bk #
           Bk # Oc(bl_bin (<aa # list @ [ab]> ) +  (2*rs + 2)* 2^(length (<aa # list @ [ab]>) - Suc 0)) @ Bk(rn))"
          apply(rule_tac ind2, simp_all)
          done
        from this obtain stpb lnb rnb where stp2: 
          "steps0 (Suc 0, Bk # Bk(lna) @  <ab # rev list @ [aa]> @ Bk # Bk # ires,
           Bk # Oc(Suc (2*rs + 2)) @ Bk(rna)) t_wcode_main stpb
           = (0, Bk # ires, Bk # Oc # Bk(lnb) @ Bk #
           Bk # Oc(bl_bin (<aa # list @ [ab]> ) +  (2*rs + 2)* 2^(length (<aa # list @ [ab]>) - Suc 0)) @ Bk(rnb))" 
          by blast
        from stp1 and stp2 show 
          "stp ln rn.
           steps0 (Suc 0, Bk # Bk(m) @ Oc(Suc (Suc ab)) @ Bk # <rev list @ [aa]> @ Bk # Bk # ires,
           Bk # Oc(Suc rs) @ Bk(n)) t_wcode_main stp =
           (0, Bk # ires, Bk # Oc # Bk(ln) @ Bk # Bk # 
           Oc(bl_bin (Oc(Suc aa) @ Bk # <list @ [Suc ab]>) + rs * (2 * 2 ^ (aa + length (<list @ [Suc ab]>)))) 
           @ Bk(rn))"
          apply(rule_tac x = "stpa + stpb" in exI, rule_tac x = lnb in exI,
              rule_tac x = rnb in exI, simp add: steps_add tape_of_nl_cons_app1 replicate_Suc)
          done
      qed
    qed
  qed
qed


definition t_wcode_prepare :: "instr list"
  where
    "t_wcode_prepare  
         [(W1, 2), (L, 1), (L, 3), (R, 2), (R, 4), (W0, 3),
          (R, 4), (R, 5), (R, 6), (R, 5), (R, 7), (R, 5),
          (W1, 7), (L, 0)]"

fun wprepare_add_one :: "nat  nat list  tape  bool"
  where
    "wprepare_add_one m lm (l, r) = 
      ( rn. l = [] 
               (r = <m # lm> @ Bk(rn)  
                r = Bk # <m # lm> @ Bk(rn)))"

fun wprepare_goto_first_end :: "nat  nat list  tape  bool"
  where
    "wprepare_goto_first_end m lm (l, r) = 
      ( ml mr rn. l = Oc(ml) 
                      r = Oc(mr) @ Bk # <lm> @ Bk(rn) 
                      ml + mr = Suc (Suc m))"

fun wprepare_erase :: "nat  nat list  tape   bool"
  where
    "wprepare_erase m lm (l, r) = 
     ( rn. l = Oc(Suc m)  
               tl r = Bk # <lm> @ Bk(rn))"

fun wprepare_goto_start_pos_B :: "nat  nat list  tape  bool"
  where
    "wprepare_goto_start_pos_B m lm (l, r) = 
     ( rn. l = Bk # Oc(Suc m) 
               r = Bk # <lm> @ Bk(rn))"

fun wprepare_goto_start_pos_O :: "nat  nat list  tape  bool"
  where
    "wprepare_goto_start_pos_O m lm (l, r) = 
     ( rn. l = Bk # Bk # Oc(Suc m) 
               r = <lm> @ Bk(rn))"

fun wprepare_goto_start_pos :: "nat  nat list  tape  bool"
  where
    "wprepare_goto_start_pos m lm (l, r) = 
       (wprepare_goto_start_pos_B m lm (l, r) 
        wprepare_goto_start_pos_O m lm (l, r))"

fun wprepare_loop_start_on_rightmost :: "nat  nat list  tape  bool"
  where
    "wprepare_loop_start_on_rightmost m lm (l, r) = 
     ( rn mr. rev l @ r = Oc(Suc m) @ Bk # Bk # <lm> @ Bk(rn)  l  [] 
                       r = Oc(mr) @ Bk(rn))"

fun wprepare_loop_start_in_middle :: "nat  nat list  tape  bool"
  where
    "wprepare_loop_start_in_middle m lm (l, r) =
     ( rn (mr:: nat) (lm1::nat list). 
  rev l @ r = Oc(Suc m) @ Bk # Bk # <lm> @ Bk(rn)  l  [] 
  r = Oc(mr) @ Bk # <lm1> @ Bk(rn)  lm1  [])"

fun wprepare_loop_start :: "nat  nat list  tape  bool"
  where
    "wprepare_loop_start m lm (l, r) = (wprepare_loop_start_on_rightmost m lm (l, r)  
                                      wprepare_loop_start_in_middle m lm (l, r))"

fun wprepare_loop_goon_on_rightmost :: "nat  nat list  tape  bool"
  where
    "wprepare_loop_goon_on_rightmost m lm (l, r) = 
     ( rn. l = Bk # <rev lm> @ Bk # Bk # Oc(Suc m) 
               r = Bk(rn))"

fun wprepare_loop_goon_in_middle :: "nat  nat list  tape  bool"
  where
    "wprepare_loop_goon_in_middle m lm (l, r) = 
     ( rn (mr:: nat) (lm1::nat list). 
  rev l @ r = Oc(Suc m) @ Bk # Bk # <lm> @ Bk(rn)  l  [] 
                     (if lm1 = [] then r = Oc(mr) @ Bk(rn) 
                     else r = Oc(mr) @ Bk # <lm1> @ Bk(rn))  mr > 0)"

fun wprepare_loop_goon :: "nat  nat list  tape  bool"
  where
    "wprepare_loop_goon m lm (l, r) = 
              (wprepare_loop_goon_in_middle m lm (l, r)  
               wprepare_loop_goon_on_rightmost m lm (l, r))"

fun wprepare_add_one2 :: "nat  nat list  tape  bool"
  where
    "wprepare_add_one2 m lm (l, r) =
          ( rn. l = Bk # Bk # <rev lm> @ Bk # Bk # Oc(Suc m) 
               (r = []  tl r = Bk(rn)))"

fun wprepare_stop :: "nat  nat list  tape  bool"
  where
    "wprepare_stop m lm (l, r) = 
         ( rn. l = Bk # <rev lm> @ Bk # Bk # Oc(Suc m) 
               r = Bk # Oc # Bk(rn))"

fun wprepare_inv :: "nat  nat  nat list  tape  bool"
  where
    "wprepare_inv st m lm (l, r) = 
        (if st = 0 then wprepare_stop m lm (l, r) 
         else if st = Suc 0 then wprepare_add_one m lm (l, r)
         else if st = Suc (Suc 0) then wprepare_goto_first_end m lm (l, r)
         else if st = Suc (Suc (Suc 0)) then wprepare_erase m lm (l, r)
         else if st = 4 then wprepare_goto_start_pos m lm (l, r)
         else if st = 5 then wprepare_loop_start m lm (l, r)
         else if st = 6 then wprepare_loop_goon m lm (l, r)
         else if st = 7 then wprepare_add_one2 m lm (l, r)
         else False)"

fun wprepare_stage :: "config  nat"
  where
    "wprepare_stage (st, l, r) = 
      (if st  1  st  4 then 3
       else if st = 5  st = 6 then 2
       else 1)"

fun wprepare_state :: "config  nat"
  where
    "wprepare_state (st, l, r) = 
       (if st = 1 then 4
        else if st = Suc (Suc 0) then 3
        else if st = Suc (Suc (Suc 0)) then 2
        else if st = 4 then 1
        else if st = 7 then 2
        else 0)"

fun wprepare_step :: "config  nat"
  where
    "wprepare_step (st, l, r) = 
      (if st = 1 then (if hd r = Oc then Suc (length l)
                       else 0)
       else if st = Suc (Suc 0) then length r
       else if st = Suc (Suc (Suc 0)) then (if hd r = Oc then 1
                            else 0)
       else if st = 4 then length r
       else if st = 5 then Suc (length r)
       else if st = 6 then (if r = [] then 0 else Suc (length r))
       else if st = 7 then (if (r  []  hd r = Oc) then 0
                            else 1)
       else 0)"

fun wcode_prepare_measure :: "config  nat × nat × nat"
  where
    "wcode_prepare_measure (st, l, r) = 
     (wprepare_stage (st, l, r), 
      wprepare_state (st, l, r), 
      wprepare_step (st, l, r))"

definition wcode_prepare_le :: "(config × config) set"
  where "wcode_prepare_le  (inv_image lex_triple wcode_prepare_measure)"

lemma wf_wcode_prepare_le[intro]: "wf wcode_prepare_le"
  by(auto intro:wf_inv_image simp: wcode_prepare_le_def 
      lex_triple_def)

declare wprepare_add_one.simps[simp del] wprepare_goto_first_end.simps[simp del]
  wprepare_erase.simps[simp del] wprepare_goto_start_pos.simps[simp del]
  wprepare_loop_start.simps[simp del] wprepare_loop_goon.simps[simp del]
  wprepare_add_one2.simps[simp del]

lemmas wprepare_invs = wprepare_add_one.simps wprepare_goto_first_end.simps
  wprepare_erase.simps wprepare_goto_start_pos.simps
  wprepare_loop_start.simps wprepare_loop_goon.simps
  wprepare_add_one2.simps

declare wprepare_inv.simps[simp del]

lemma fetch_t_wcode_prepare[simp]:
  "fetch t_wcode_prepare (Suc 0) Bk = (W1, 2)"
  "fetch t_wcode_prepare (Suc 0) Oc = (L, 1)"
  "fetch t_wcode_prepare (Suc (Suc 0)) Bk = (L, 3)"
  "fetch t_wcode_prepare (Suc (Suc 0)) Oc = (R, 2)"
  "fetch t_wcode_prepare (Suc (Suc (Suc 0))) Bk = (R, 4)"
  "fetch t_wcode_prepare (Suc (Suc (Suc 0))) Oc = (W0, 3)"
  "fetch t_wcode_prepare 4 Bk = (R, 4)"
  "fetch t_wcode_prepare 4 Oc = (R, 5)"
  "fetch t_wcode_prepare 5 Oc = (R, 5)"
  "fetch t_wcode_prepare 5 Bk = (R, 6)"
  "fetch t_wcode_prepare 6 Oc = (R, 5)"
  "fetch t_wcode_prepare 6 Bk = (R, 7)"
  "fetch t_wcode_prepare 7 Oc = (L, 0)"
  "fetch t_wcode_prepare 7 Bk = (W1, 7)"
  unfolding fetch.simps t_wcode_prepare_def nth_of.simps
    numeral by auto

lemma wprepare_add_one_nonempty_snd[simp]: "lm  []  wprepare_add_one m lm (b, []) = False"
  apply(simp add: wprepare_invs)
  done

lemma wprepare_goto_first_end_nonempty_snd[simp]: "lm  []  wprepare_goto_first_end m lm (b, []) = False"
  apply(simp add: wprepare_invs)
  done

lemma wprepare_erase_nonempty_snd[simp]: "lm  []  wprepare_erase m lm (b, []) = False"
  apply(simp add: wprepare_invs)
  done

lemma wprepare_goto_start_pos_nonempty_snd[simp]: "lm  []  wprepare_goto_start_pos m lm (b, []) = False"
  apply(simp add: wprepare_invs)
  done

lemma wprepare_loop_start_empty_nonempty_fst[simp]: "lm  []; wprepare_loop_start m lm (b, [])  b  []"
  apply(simp add: wprepare_invs)
  done

lemma rev_eq: "rev xs = rev ys  xs = ys" by auto

lemma wprepare_loop_goon_Bk_empty_snd[simp]: "lm  []; wprepare_loop_start m lm (b, [])  
                                  wprepare_loop_goon m lm (Bk # b, [])"
  apply(simp only: wprepare_invs)
  apply(erule_tac disjE)
   apply(rule_tac disjI2)
   apply(simp add: wprepare_loop_start_on_rightmost.simps
      wprepare_loop_goon_on_rightmost.simps, auto)
  apply(rule_tac rev_eq, simp add: tape_of_nl_rev)
  done

lemma wprepare_loop_goon_nonempty_fst[simp]: "lm  []; wprepare_loop_goon m lm (b, [])  b  []"
  apply(simp only: wprepare_invs, auto)
  done

lemma wprepare_add_one2_Bk_empty[simp]:"lm  []; wprepare_loop_goon m lm (b, [])  
  wprepare_add_one2 m lm (Bk # b, [])"
  apply(simp only: wprepare_invs, auto split: if_splits)
  done

lemma wprepare_add_one2_nonempty_fst[simp]: "wprepare_add_one2 m lm (b, [])  b  []"
  apply(simp only: wprepare_invs, auto)
  done

lemma wprepare_add_one2_Oc[simp]: "wprepare_add_one2 m lm (b, [])  wprepare_add_one2 m lm (b, [Oc])"
  apply(simp only: wprepare_invs, auto)
  done

lemma Bk_not_tape_start[simp]: "(Bk # list = <(m::nat) # lm> @ ys) = False"
  apply(case_tac lm, auto simp: tape_of_nl_cons replicate_Suc)
  done

lemma wprepare_goto_first_end_cases[simp]:
  "lm  []; wprepare_add_one m lm (b, Bk # list)
        (b = []  wprepare_goto_first_end m lm ([], Oc # list))  
           (b  []  wprepare_goto_first_end m lm (b, Oc # list))"
  apply(simp only: wprepare_invs)
  apply(auto simp: tape_of_nl_cons split: if_splits)
  apply(cases lm, auto simp add:tape_of_list_def replicate_Suc)
  done

lemma wprepare_goto_first_end_Bk_nonempty_fst[simp]:
  "wprepare_goto_first_end m lm (b, Bk # list)  b  []"
  apply(simp only: wprepare_invs , auto simp: replicate_Suc)
  done

declare replicate_Suc[simp]

lemma wprepare_erase_elem_Bk_rest[simp]: "wprepare_goto_first_end m lm (b, Bk # list) 
                          wprepare_erase m lm (tl b, hd b # Bk # list)"
  by(simp add: wprepare_invs)

lemma wprepare_erase_Bk_nonempty_fst[simp]: "wprepare_erase m lm (b, Bk # list)  b  []"
  by(simp add: wprepare_invs)

lemma wprepare_goto_start_pos_Bk[simp]: "wprepare_erase m lm (b, Bk # list)  
                           wprepare_goto_start_pos m lm (Bk # b, list)"
  apply(simp only: wprepare_invs, auto)
  done

lemma wprepare_add_one_Bk_nonempty_snd[simp]: "wprepare_add_one m lm (b, Bk # list)  list  []"
  apply(simp only: wprepare_invs)
  apply(case_tac lm, simp_all add: tape_of_list_def tape_of_nat_def, auto)
  done

lemma wprepare_goto_first_end_nonempty_snd_tl[simp]:
  "lm  [];  wprepare_goto_first_end m lm (b, Bk # list)  list  []"
  by(simp only: wprepare_invs, auto)

lemma wprepare_erase_Bk_nonempty_list[simp]: "lm  []; wprepare_erase m lm (b, Bk # list)  list  []"
  apply(simp only: wprepare_invs, auto)
  done


lemma wprepare_goto_start_pos_Bk_nonempty[simp]: "lm  [];  wprepare_goto_start_pos m lm (b, Bk # list)  list  []"
  by(cases lm;cases list;simp only: wprepare_invs, auto)

lemma wprepare_goto_start_pos_Bk_nonempty_fst[simp]: "lm  [];  wprepare_goto_start_pos m lm (b, Bk # list)  b  []"
  apply(simp only: wprepare_invs)
  apply(auto)
  done

lemma wprepare_loop_goon_Bk_nonempty[simp]: "lm  []; wprepare_loop_goon m lm (b, Bk # list)  b  []"
  apply(simp only: wprepare_invs, auto)
  done

lemma wprepare_loop_goon_wprepare_add_one2_cases[simp]: "lm  []; wprepare_loop_goon m lm (b, Bk # list)  
  (list = []  wprepare_add_one2 m lm (Bk # b, []))  
  (list  []  wprepare_add_one2 m lm (Bk # b, list))"
  unfolding wprepare_invs
  apply(cases list;auto split:nat.split if_splits)
  by (metis list.sel(3) tl_replicate)

lemma wprepare_add_one2_nonempty[simp]: "wprepare_add_one2 m lm (b, Bk # list)  b  []"
  apply(simp only: wprepare_invs, simp)
  done

lemma wprepare_add_one2_cases[simp]: "wprepare_add_one2 m lm (b, Bk # list)  
      (list = []  wprepare_add_one2 m lm (b, [Oc]))  
      (list  []  wprepare_add_one2 m lm (b, Oc # list))"
  apply(simp only:  wprepare_invs, auto)
  done

lemma wprepare_goto_first_end_cases_Oc[simp]: "wprepare_goto_first_end m lm (b, Oc # list)
        (b = []  wprepare_goto_first_end m lm ([Oc], list))  
           (b  []  wprepare_goto_first_end m lm (Oc # b, list))"
  apply(simp only:  wprepare_invs, auto)
   apply(rule_tac x = 1 in exI, auto) apply(rename_tac ml mr rn)
  apply(case_tac mr, simp_all add: )
  apply(case_tac ml, simp_all add: )
  apply(rule_tac x = "Suc ml" in exI, simp_all add: )
  apply(rule_tac x = "mr - 1" in exI, simp)
  done

lemma wprepare_erase_nonempty[simp]: "wprepare_erase m lm (b, Oc # list)  b  []"
  apply(simp only: wprepare_invs, auto simp: )
  done

lemma wprepare_erase_Bk[simp]: "wprepare_erase m lm (b, Oc # list)
   wprepare_erase m lm (b, Bk # list)"
  apply(simp  only:wprepare_invs, auto simp: )
  done

lemma wprepare_goto_start_pos_Bk_move[simp]: "lm  []; wprepare_goto_start_pos m lm (b, Bk # list)
        wprepare_goto_start_pos m lm (Bk # b, list)"
  apply(simp only:wprepare_invs, auto)
          apply(case_tac [!] lm, simp, simp_all)
  done

lemma wprepare_loop_start_b_nonempty[simp]: "wprepare_loop_start m lm (b, aa)  b  []"
  apply(simp only:wprepare_invs, auto)
  done
lemma exists_exp_of_Bk[elim]: "Bk # list = Oc(mr) @ Bk(rn)   rn. list = Bk(rn)"
  apply(case_tac mr, simp_all)
  apply(case_tac rn, simp_all)
  done

lemma wprepare_loop_start_in_middle_Bk_False[simp]: "wprepare_loop_start_in_middle m lm (b, [Bk]) = False"
  by(auto)

declare wprepare_loop_start_in_middle.simps[simp del]

declare wprepare_loop_start_on_rightmost.simps[simp del] 
  wprepare_loop_goon_in_middle.simps[simp del]
  wprepare_loop_goon_on_rightmost.simps[simp del]

lemma wprepare_loop_goon_in_middle_Bk_False[simp]: "wprepare_loop_goon_in_middle m lm (Bk # b, []) = False"
  apply(simp add: wprepare_loop_goon_in_middle.simps, auto)
  done

lemma wprepare_loop_goon_Bk[simp]: "lm  []; wprepare_loop_start m lm (b, [Bk]) 
  wprepare_loop_goon m lm (Bk # b, [])"
  unfolding wprepare_invs
  apply(auto simp add: wprepare_loop_goon_on_rightmost.simps 
      wprepare_loop_start_on_rightmost.simps)
  apply(rule_tac rev_eq)
  apply(simp add: tape_of_nl_rev)
  apply(simp add: exp_ind replicate_Suc[THEN sym] del: replicate_Suc)
  done

lemma wprepare_loop_goon_in_middle_Bk_False2[simp]: "wprepare_loop_start_on_rightmost m lm (b, Bk # a # lista)
  wprepare_loop_goon_in_middle m lm (Bk # b, a # lista) = False"
  apply(auto simp: wprepare_loop_start_on_rightmost.simps
      wprepare_loop_goon_in_middle.simps)
  done

lemma wprepare_loop_goon_on_rightbmost_Bk_False[simp]: "lm  []; wprepare_loop_start_on_rightmost m lm (b, Bk # a # lista)
     wprepare_loop_goon_on_rightmost m lm (Bk # b, a # lista)"
  apply(simp only: wprepare_loop_start_on_rightmost.simps
      wprepare_loop_goon_on_rightmost.simps, auto simp: tape_of_nl_rev)
   apply(simp add: replicate_Suc[THEN sym] exp_ind tape_of_nl_rev del: replicate_Suc)
  by (meson Cons_replicate_eq)


lemma wprepare_loop_goon_in_middle_Bk_False3[simp]: 
  assumes "lm  []" "wprepare_loop_start_in_middle m lm (b, Bk # a # lista)"
  shows "wprepare_loop_goon_in_middle m lm (Bk # b, a # lista)" (is "?t1")
    and "wprepare_loop_goon_on_rightmost m lm (Bk # b, a # lista) = False" (is ?t2)
proof -
  from assms obtain rn mr lm1 where *:"rev b @ Oc  mr @ Bk # <lm1> = Oc # Oc  m @ Bk # Bk # <lm>"
    "b  []" "Bk # a # lista = Oc  mr @ Bk # <lm1::nat list> @ Bk  rn" "lm1  []"
    by(auto simp add: wprepare_loop_start_in_middle.simps)
  thus ?t1 apply(simp add: wprepare_loop_start_in_middle.simps
        wprepare_loop_goon_in_middle.simps, auto)
    apply(rule_tac x = rn in exI, simp)
    apply(case_tac mr, simp_all add: )
    apply(case_tac lm1, simp)
    apply(rule_tac x = "Suc (hd lm1)" in exI, simp)
    apply(rule_tac x = "tl lm1" in exI)
    apply(case_tac "tl lm1", simp_all add: tape_of_list_def  tape_of_nat_def)
    done
  from * show ?t2 
    apply(simp add: wprepare_loop_start_in_middle.simps
        wprepare_loop_goon_on_rightmost.simps del:split_head_repeat, auto simp del:split_head_repeat)
     apply(case_tac mr)
      apply(case_tac  "lm1::nat list", simp_all, case_tac "tl lm1", simp_all)
      apply(auto simp add: tape_of_list_def )
      apply(case_tac [!] rna, simp_all add: )
     apply(case_tac mr, simp_all add: )
     apply(case_tac lm1, simp, case_tac list, simp)
     apply(simp_all add: tape_of_nat_def)
    by (metis Bk_not_tape_start tape_of_list_def tape_of_nat_list.elims)
qed

lemma wprepare_loop_goon_Bk2[simp]: "lm  []; wprepare_loop_start m lm (b, Bk # a # lista)  
  wprepare_loop_goon m lm (Bk # b, a # lista)"
  apply(simp add: wprepare_loop_start.simps 
      wprepare_loop_goon.simps)
  apply(erule_tac disjE, simp, auto)
  done

lemma start_2_goon:
  "lm  []; wprepare_loop_start m lm (b, Bk # list) 
   (list = []  wprepare_loop_goon m lm (Bk # b, [])) 
  (list  []  wprepare_loop_goon m lm (Bk # b, list))"
  apply(case_tac list, auto)
  done

lemma add_one_2_add_one: "wprepare_add_one m lm (b, Oc # list)
   (hd b = Oc  (b = []  wprepare_add_one m lm ([], Bk # Oc # list)) 
                     (b  []  wprepare_add_one m lm (tl b, Oc # Oc # list))) 
  (hd b  Oc  (b = []  wprepare_add_one m lm ([], Bk # Oc # list)) 
                 (b  []  wprepare_add_one m lm (tl b, hd b # Oc # list)))"
  unfolding wprepare_add_one.simps by auto

lemma wprepare_loop_start_on_rightmost_Oc[simp]: "wprepare_loop_start_on_rightmost m lm (b, Oc # list)  
  wprepare_loop_start_on_rightmost m lm (Oc # b, list)"
  apply(simp add: wprepare_loop_start_on_rightmost.simps)
  by (metis Cons_replicate_eq cell.distinct(1) list.sel(3) self_append_conv2 tl_append2 tl_replicate)

lemma wprepare_loop_start_in_middle_Oc[simp]:
  assumes "wprepare_loop_start_in_middle m lm (b, Oc # list)"
  shows "wprepare_loop_start_in_middle m lm (Oc # b, list)"
proof -
  from assms obtain mr lm1 rn
    where "rev b @ Oc  mr @ Bk # <lm1::nat list> = Oc # Oc  m @ Bk # Bk # <lm>"
      "Oc # list = Oc  mr @ Bk # <lm1> @ Bk  rn" "lm1  []"
    by(auto simp add: wprepare_loop_start_in_middle.simps)
  thus ?thesis 
    apply(auto simp add: wprepare_loop_start_in_middle.simps)
    apply(rule_tac x = rn in exI, auto)
    apply(case_tac mr, simp, simp add: )
    apply(rule_tac x = "mr - 1" in exI, simp)
    apply(rule_tac x = lm1 in exI, simp)
    done
qed

lemma start_2_start: "wprepare_loop_start m lm (b, Oc # list)  
       wprepare_loop_start m lm (Oc # b, list)"
  apply(simp add: wprepare_loop_start.simps)
  apply(erule_tac disjE, simp_all )
  done

lemma wprepare_loop_goon_Oc_nonempty[simp]: "wprepare_loop_goon m lm (b, Oc # list)  b  []"
  apply(simp add: wprepare_loop_goon.simps     
      wprepare_loop_goon_in_middle.simps 
      wprepare_loop_goon_on_rightmost.simps)
  apply(auto)
  done

lemma wprepare_goto_start_pos_Oc_nonempty[simp]: "wprepare_goto_start_pos m lm (b, Oc # list)  b  []"
  apply(simp add: wprepare_goto_start_pos.simps)
  done

lemma wprepare_loop_goon_on_rightmost_Oc_False[simp]: "wprepare_loop_goon_on_rightmost m lm (b, Oc # list) = False"
  apply(simp add: wprepare_loop_goon_on_rightmost.simps)
  done

lemma wprepare_loop1: "rev b @ Oc(mr) =  Oc(Suc m) @ Bk # Bk # <lm>; 
         b  []; 0 < mr; Oc # list = Oc(mr) @ Bk(rn)
        wprepare_loop_start_on_rightmost m lm (Oc # b, list)"
  apply(simp add: wprepare_loop_start_on_rightmost.simps)
  apply(rule_tac x = rn in exI, simp)
  apply(case_tac mr, simp, simp)
  done

lemma wprepare_loop2: "rev b @ Oc(mr) @ Bk # <a # lista> = Oc(Suc m) @ Bk # Bk # <lm>;
                b  []; Oc # list = Oc(mr) @ Bk # <(a::nat) # lista> @ Bk(rn)
         wprepare_loop_start_in_middle m lm (Oc # b, list)"
  apply(simp add: wprepare_loop_start_in_middle.simps)
  apply(rule_tac x = rn in exI, simp)
  apply(case_tac mr, simp_all add: ) apply(rename_tac nat)
  apply(rule_tac x = nat in exI, simp)
  apply(rule_tac x = "a#lista" in exI, simp)
  done

lemma wprepare_loop_goon_in_middle_cases[simp]: "wprepare_loop_goon_in_middle m lm (b, Oc # list) 
                wprepare_loop_start_on_rightmost m lm (Oc # b, list) 
                wprepare_loop_start_in_middle m lm (Oc # b, list)"
  apply(simp add: wprepare_loop_goon_in_middle.simps split: if_splits) apply(rename_tac lm1)
  apply(case_tac lm1, simp_all add: wprepare_loop1 wprepare_loop2)
  done

lemma wprepare_add_one_b[simp]: "wprepare_add_one m lm (b, Oc # list)
        b = []  wprepare_add_one m lm ([], Bk # Oc # list)"
  "wprepare_loop_goon m lm (b, Oc # list)
    wprepare_loop_start m lm (Oc # b, list)"
   apply(auto simp add: wprepare_add_one.simps wprepare_loop_goon.simps
      wprepare_loop_start.simps)
  done

lemma wprepare_loop_start_on_rightmost_Oc2[simp]: "wprepare_goto_start_pos m [a] (b, Oc # list)
               wprepare_loop_start_on_rightmost m [a] (Oc # b, list) "
  apply(auto simp: wprepare_goto_start_pos.simps 
      wprepare_loop_start_on_rightmost.simps) apply(rename_tac rn)
  apply(rule_tac x = rn in exI, simp)
  apply(simp add: replicate_Suc[THEN sym] exp_ind del: replicate_Suc)
  done

lemma wprepare_loop_start_in_middle_2_Oc[simp]:  "wprepare_goto_start_pos m (a # aa # listaa) (b, Oc # list)
       wprepare_loop_start_in_middle m (a # aa # listaa) (Oc # b, list)"
  apply(auto simp: wprepare_goto_start_pos.simps
      wprepare_loop_start_in_middle.simps) apply(rename_tac rn)
  apply(rule_tac x = rn in exI, simp)
  apply(simp add: exp_ind[THEN sym])
  apply(rule_tac x = a in exI, rule_tac x = "aa#listaa" in exI, simp)
  apply(simp add: tape_of_nl_cons)
  done

lemma wprepare_loop_start_Oc2[simp]: "lm  []; wprepare_goto_start_pos m lm (b, Oc # list)
        wprepare_loop_start m lm (Oc # b, list)"
  by(cases lm;cases "tl lm", auto simp add: wprepare_loop_start.simps)

lemma wprepare_add_one2_Oc_nonempty[simp]: "wprepare_add_one2 m lm (b, Oc # list)  b  []"
  apply(auto simp: wprepare_add_one2.simps)
  done

lemma add_one_2_stop:
  "wprepare_add_one2 m lm (b, Oc # list)      
    wprepare_stop m lm (tl b, hd b # Oc # list)"
  apply(simp add: wprepare_add_one2.simps)
  done

declare wprepare_stop.simps[simp del]

lemma wprepare_correctness:
  assumes h: "lm  []"
  shows "let P = (λ (st, l, r). st = 0) in 
  let Q = (λ (st, l, r). wprepare_inv st m lm (l, r)) in 
  let f = (λ stp. steps0 (Suc 0, [], (<m # lm>)) t_wcode_prepare stp) in
     n .P (f n)  Q (f n)"
proof -
  let ?P = "(λ (st, l, r). st = 0)"
  let ?Q = "(λ (st, l, r). wprepare_inv st m lm (l, r))"
  let ?f = "(λ stp. steps0 (Suc 0, [], (<m # lm>)) t_wcode_prepare stp)"
  have " n. ?P (?f n)  ?Q (?f n)"
  proof(rule_tac halt_lemma2)
    show " n. ¬ ?P (?f n)  ?Q (?f n)  
                 ?Q (?f (Suc n))  (?f (Suc n), ?f n)  wcode_prepare_le"
      using h
      apply(rule_tac allI, rule_tac impI) apply(rename_tac n)
      apply(case_tac "?f n", simp add: step.simps) apply(rename_tac c)
      apply(case_tac c, simp, case_tac [2] aa)
        apply(simp_all add: wprepare_inv.simps wcode_prepare_le_def lex_triple_def lex_pair_def
          split: if_splits) (* slow *)
         apply(simp_all add: start_2_goon  start_2_start
          add_one_2_add_one add_one_2_stop)
      apply(auto simp: wprepare_add_one2.simps)
      done
  qed (auto simp add: steps.simps wprepare_inv.simps wprepare_invs)
  thus "?thesis"
    apply(auto)
    done
qed

lemma tm_wf_t_wcode_prepare[intro]: "tm_wf (t_wcode_prepare, 0)"
  apply(simp add:tm_wf.simps t_wcode_prepare_def)
  done

lemma is_28_even[intro]: "(28 + (length t_twice_compile + length t_fourtimes_compile)) mod 2 = 0"
  by(auto simp: t_twice_compile_def t_fourtimes_compile_def)

lemma b_le_28[elim]: "(a, b)  set t_wcode_main_first_part 
  b  (28 + (length t_twice_compile + length t_fourtimes_compile)) div 2"
  apply(auto simp: t_wcode_main_first_part_def t_twice_def)
  done



lemma tm_wf_change_termi:
  assumes "tm_wf (tp, 0)"
  shows "list_all (λ(acn, st). (st  Suc (length tp div 2))) (adjust0 tp)"
proof -
  { fix acn st n
    assume "tp ! n = (acn, st)" "n < length tp" "0 < st"
    hence "(acn, st)set tp" by (metis nth_mem)
    with assms tm_wf.simps have "st  length tp div 2 + 0" by auto
    hence "st  Suc (length tp div 2)" by auto
  }
  thus ?thesis
    by(auto simp: tm_wf.simps List.list_all_length adjust.simps split: if_splits prod.split)
qed

lemma tm_wf_shift:
  assumes "list_all (λ(acn, st). (st  y)) tp"
  shows "list_all (λ(acn, st). (st  y + off)) (shift tp off)"
proof -
  have [dest!]:" P Q n. n. Q n  P n  Q n  P n" by metis
  from assms show ?thesis by(auto simp: tm_wf.simps List.list_all_length shift.simps)
qed

declare length_tp'[simp del]

lemma length_mopup_1[simp]: "length (mopup (Suc 0)) = 16"
  apply(auto simp: mopup.simps)
  done

lemma twice_plus_28_elim[elim]: "(a, b)  set (shift (adjust0 t_twice_compile) 12)  
  b  (28 + (length t_twice_compile + length t_fourtimes_compile)) div 2"
  apply(simp add: t_twice_compile_def t_fourtimes_compile_def)
proof -
  assume g: "(a, b)
     set (shift
            (adjust
              (tm_of abc_twice @
               shift (mopup (Suc 0)) (length (tm_of abc_twice) div 2))
              (Suc ((length (tm_of abc_twice) + 16) div 2)))
            12)"
  moreover have "length (tm_of abc_twice) mod 2 = 0" by auto
  moreover have "length (tm_of abc_fourtimes) mod 2 = 0" by auto
  ultimately have "list_all (λ(acn, st). (st  (60 + (length (tm_of abc_twice) + length (tm_of abc_fourtimes))) div 2)) 
    (shift (adjust0 t_twice_compile) 12)"
  proof(auto simp add: mod_ex1 del: adjust.simps)
    assume "even (length (tm_of abc_twice))"
    then obtain q where q:"length (tm_of abc_twice) = 2 * q" by auto
    assume "even (length (tm_of abc_fourtimes))"
    then obtain qa where qa:"length (tm_of abc_fourtimes) = 2 * qa" by auto
    note h = q qa
    hence "list_all (λ(acn, st). st  (18 + (q + qa)) + 12) (shift (adjust0 t_twice_compile) 12)"
    proof(rule_tac tm_wf_shift t_twice_compile_def)
      have "list_all (λ(acn, st). st  Suc (length t_twice_compile div 2)) (adjust0 t_twice_compile)"
        by(rule_tac tm_wf_change_termi, auto)
      thus "list_all (λ(acn, st). st  18 + (q + qa)) (adjust0 t_twice_compile)"
        using h
        apply(simp add: t_twice_compile_def, auto simp: List.list_all_length)
        done
    qed
    thus "list_all (λ(acn, st). st  30 + (length (tm_of abc_twice) div 2 + length (tm_of abc_fourtimes) div 2))
     (shift (adjust0 t_twice_compile) 12)" using h
      by simp
  qed
  thus "b  (60 + (length (tm_of abc_twice) + length (tm_of abc_fourtimes))) div 2"
    using g
    apply(auto simp:t_twice_compile_def)
    apply(simp add: Ball_set[THEN sym])
    apply(erule_tac x = "(a, b)" in ballE, simp, simp)
    done
qed 

lemma length_plus_28_elim2[elim]: "(a, b)  set (shift (adjust0 t_fourtimes_compile) (t_twice_len + 13)) 
   b  (28 + (length t_twice_compile + length t_fourtimes_compile)) div 2"
  apply(simp add: t_twice_compile_def t_fourtimes_compile_def t_twice_len_def)
proof -
  assume g: "(a, b)
     set (shift
             (adjust (tm_of abc_fourtimes @ shift (mopup (Suc 0)) (length (tm_of abc_fourtimes) div 2))
               (Suc ((length (tm_of abc_fourtimes) + 16) div 2)))
             (length t_twice div 2 + 13))"
  moreover have "length (tm_of abc_twice) mod 2 = 0" by auto
  moreover have "length (tm_of abc_fourtimes) mod 2 = 0" by auto
  ultimately have "list_all (λ(acn, st). (st  (60 + (length (tm_of abc_twice) + length (tm_of abc_fourtimes))) div 2)) 
    (shift (adjust0 (tm_of abc_fourtimes @ shift (mopup (Suc 0))
    (length (tm_of abc_fourtimes) div 2))) (length t_twice div 2 + 13))"
  proof(auto simp: mod_ex1 t_twice_def t_twice_compile_def)
    assume "even (length (tm_of abc_twice))"
    then obtain q where q:"length (tm_of abc_twice) = 2 * q" by auto
    assume "even (length (tm_of abc_fourtimes))"
    then obtain qa where qa:"length (tm_of abc_fourtimes) = 2 * qa" by auto
    note h = q qa
    hence "list_all (λ(acn, st). st  (9 + qa + (21 + q)))
      (shift (adjust0 (tm_of abc_fourtimes @ shift (mopup (Suc 0)) qa)) (21 + q))"
    proof(rule_tac tm_wf_shift t_twice_compile_def)
      have "list_all (λ(acn, st). st  Suc (length (tm_of abc_fourtimes @ shift 
        (mopup (Suc 0)) qa) div 2)) (adjust0 (tm_of abc_fourtimes @ shift (mopup (Suc 0)) qa))"
        apply(rule_tac tm_wf_change_termi)
        using wf_fourtimes h
        apply(simp add: t_fourtimes_compile_def)
        done
      thus "list_all (λ(acn, st). st  9 + qa)
        (adjust (tm_of abc_fourtimes @ shift (mopup (Suc 0)) qa)
          (Suc (length (tm_of abc_fourtimes @ shift (mopup (Suc 0)) qa) div
                2)))"
        using h
        apply(simp)
        done
    qed
    thus "list_all
     (λ(acn, st). st  30 + (length (tm_of abc_twice) div 2 + length (tm_of abc_fourtimes) div 2))
     (shift
       (adjust (tm_of abc_fourtimes @ shift (mopup (Suc 0)) (length (tm_of abc_fourtimes) div 2))
         (9 + length (tm_of abc_fourtimes) div 2))
       (21 + length (tm_of abc_twice) div 2))"
      apply(subgoal_tac "qa + q = q + qa")
       apply(simp add: h)
      apply(simp)
      done
  qed
  thus "b  (60 + (length (tm_of abc_twice) + length (tm_of abc_fourtimes))) div 2"
    using g
    apply(simp add: Ball_set[THEN sym])
    apply(erule_tac x = "(a, b)" in ballE, simp, simp)
    done
qed

lemma tm_wf_t_wcode_main[intro]: "tm_wf (t_wcode_main, 0)"
  by(auto simp: t_wcode_main_def tm_wf.simps
      t_twice_def t_fourtimes_def del: List.list_all_iff)

declare tm_comp.simps[simp del]

lemma prepare_mainpart_lemma:
  "args  []  
   stp ln rn. steps0 (Suc 0, [], <m # args>) (t_wcode_prepare |+| t_wcode_main) stp
              = (0,  Bk # Oc(Suc m), Bk # Oc # Bk(ln) @ Bk # Bk # Oc(bl_bin (<args>)) @ Bk(rn))"
proof -
  let ?P1 = "(λ (l, r). (l::cell list) = []  r = <m # args>)"
  let ?Q1 = "(λ (l, r). wprepare_stop m args (l, r))"
  let ?P2 = ?Q1
  let ?Q2 = "(λ (l, r). ( ln rn. l = Bk # Oc(Suc m) 
                           r =  Bk # Oc # Bk(ln) @ Bk # Bk # Oc(bl_bin (<args>)) @ Bk(rn)))"
  let ?P3 = "λ tp. False"
  assume h: "args  []"
  have "{?P1} t_wcode_prepare |+| t_wcode_main {?Q2}"
  proof(rule_tac Hoare_plus_halt)
    show "{?P1} t_wcode_prepare {?Q1}"
    proof(rule_tac Hoare_haltI, auto)
      show "n. is_final (steps0 (Suc 0, [], <m # args>) t_wcode_prepare n) 
        wprepare_stop m args holds_for steps0 (Suc 0, [], <m # args>) t_wcode_prepare n"
        using wprepare_correctness[of args m,OF h]
        apply(auto simp add: wprepare_inv.simps)
        by (metis holds_for.simps is_finalI)
    qed
  next
    show "{?P2} t_wcode_main {?Q2}"
    proof(rule_tac Hoare_haltI, auto)
      fix l r
      assume "wprepare_stop m args (l, r)"
      thus "n. is_final (steps0 (Suc 0, l, r) t_wcode_main n) 
              (λ(l, r). l = Bk # Oc # Oc  m  (ln rn. r = Bk # Oc # Bk  ln @ 
        Bk # Bk # Oc  bl_bin (<args>) @ Bk  rn)) holds_for steps0 (Suc 0, l, r) t_wcode_main n"
      proof(auto simp: wprepare_stop.simps)
        fix rn
        show " n. is_final (steps0 (Suc 0, Bk # <rev args> @ Bk # Bk # Oc # Oc  m, Bk # Oc # Bk  rn) t_wcode_main n) 
          (λ(l, r). l = Bk # Oc # Oc  m 
          (ln rn. r = Bk # Oc # Bk  ln @
          Bk # Bk # Oc  bl_bin (<args>) @
          Bk  rn)) holds_for steps0 (Suc 0, Bk # <rev args> @ Bk # Bk # Oc # Oc  m, Bk # Oc # Bk  rn) t_wcode_main n"
          using t_wcode_main_lemma_pre[of "args" "<args>" 0 "Oc(Suc m)" 0 rn,OF h refl]
          apply(auto simp: tape_of_nl_rev)
          apply(rename_tac stp ln rna)
          apply(rule_tac x = stp in exI, auto)
          done
      qed
    qed
  next
    show "tm_wf0 t_wcode_prepare"
      by auto
  qed
  then obtain n 
    where " tp. (case tp of (l, r)  l = []  r = <m # args>) 
       (is_final (steps0 (1, tp) (t_wcode_prepare |+| t_wcode_main) n) 
            (λ(l, r).
                ln rn.
                   l = Bk # Oc  Suc m 
                   r = Bk # Oc # Bk  ln @ Bk # Bk # Oc  bl_bin (<args>) @ Bk  rn) holds_for steps0 (1, tp) (t_wcode_prepare |+| t_wcode_main) n)"
    unfolding Hoare_halt_def by auto
  thus "?thesis"
    apply(rule_tac x = n in exI)
    apply(case_tac "(steps0 (Suc 0, [], <m # args>)
      (adjust0 t_wcode_prepare @ shift t_wcode_main (length t_wcode_prepare div 2)) n)")
    apply(auto simp: tm_comp.simps)
    done
qed

definition tinres :: "cell list  cell list  bool"
  where
    "tinres xs ys = (n. xs = ys @ Bk  n  ys = xs @ Bk  n)"

lemma tinres_fetch_congr[simp]:  "tinres r r'  
  fetch t ss (read r) = 
  fetch t ss (read r')"
  apply(simp add: fetch.simps, auto split: if_splits simp: tinres_def)
  using hd_replicate apply fastforce
  using hd_replicate apply fastforce
  done

lemma nonempty_hd_tinres[simp]: "tinres r r'; r  []; r'  []  hd r = hd r'"
  apply(auto simp: tinres_def)
  done

lemma tinres_nonempty[simp]:
  "tinres r []; r  []  hd r = Bk"
  "tinres [] r'; r'  []  hd r' = Bk"
  "tinres r [];  r  []  tinres (tl r) []"
  "tinres r r'  tinres (b # r) (b # r')"
  by(auto simp: tinres_def)

lemma ex_move_tl[intro]: "na. tl r = tl (r @ Bk(n)) @ Bk(na)  tl (r @ Bk(n)) = tl r @ Bk(na)"
  apply(case_tac r, simp)
  by(case_tac n, auto)

lemma tinres_tails[simp]: "tinres r r'  tinres (tl r) (tl r')"
  apply(auto simp: tinres_def)
  by(case_tac r', auto)

lemma tinres_empty[simp]: 
  "tinres [] r'  tinres [] (tl r')"
  "tinres r []  tinres (Bk # tl r) [Bk]"
  "tinres r []  tinres (Oc # tl r) [Oc]"
  by(auto simp: tinres_def)

lemma tinres_step2:
  assumes "tinres r r'" "step0 (ss, l, r) t = (sa, la, ra)" "step0 (ss, l, r') t = (sb, lb, rb)"
  shows "la = lb  tinres ra rb  sa = sb"
proof (cases "fetch t ss (read r')")
  case (Pair a b)
  have sa:"sa = sb" using assms Pair by(force simp: step.simps)
  have "la = lb  tinres ra rb" using assms Pair
    by(cases a, auto simp: step.simps split: if_splits)
  thus ?thesis using sa by auto
qed

lemma tinres_steps2: 
  "tinres r r'; steps0 (ss, l, r) t stp = (sa, la, ra); steps0 (ss, l, r') t stp = (sb, lb, rb)
     la = lb  tinres ra rb  sa = sb"
proof(induct stp arbitrary: sa la ra sb lb rb)
  case (Suc stp sa la ra sb lb rb)
  then show ?case 
    apply(simp)
    apply(case_tac "(steps0 (ss, l, r) t stp)")
    apply(case_tac "(steps0 (ss, l, r') t stp)")
  proof -
    fix stp a b c aa ba ca
    assume ind: "sa la ra sb lb rb. steps0 (ss, l, r) t stp = (sa, la, ra); 
    steps0 (ss, l, r') t stp = (sb, lb, rb)  la = lb  tinres ra rb  sa = sb"
      and h: " tinres r r'" "step0 (steps0 (ss, l, r) t stp) t = (sa, la, ra)"
      "step0 (steps0 (ss, l, r') t stp) t = (sb, lb, rb)" "steps0 (ss, l, r) t stp = (a, b, c)" 
      "steps0 (ss, l, r') t stp = (aa, ba, ca)"
    have "b = ba  tinres c ca  a = aa"
      apply(rule_tac ind, simp_all add: h)
      done
    thus "la = lb  tinres ra rb  sa = sb"
      apply(rule_tac l = b  and r = c  and ss = a and r' = ca   
          and t = t in tinres_step2)
      using h
        apply(simp, simp, simp)
      done
  qed
qed (simp add: steps.simps)


definition t_wcode_adjust :: "instr list"
  where
    "t_wcode_adjust = [(W1, 1), (R, 2), (Nop, 2), (R, 3), (R, 3), (R, 4), 
                   (L, 8), (L, 5), (L, 6), (W0, 5), (L, 6), (R, 7), 
                   (W1, 2), (Nop, 7), (L, 9), (W0, 8), (L, 9), (L, 10), 
                    (L, 11), (L, 10), (R, 0), (L, 11)]"

lemma fetch_t_wcode_adjust[simp]:
  "fetch t_wcode_adjust (Suc 0) Bk = (W1, 1)"
  "fetch t_wcode_adjust (Suc 0) Oc = (R, 2)"
  "fetch t_wcode_adjust (Suc (Suc 0)) Oc = (R, 3)"
  "fetch t_wcode_adjust (Suc (Suc (Suc 0))) Oc = (R, 4)"
  "fetch t_wcode_adjust  (Suc (Suc (Suc 0))) Bk = (R, 3)"
  "fetch t_wcode_adjust 4 Bk = (L, 8)"
  "fetch t_wcode_adjust 4 Oc = (L, 5)"
  "fetch t_wcode_adjust 5 Oc = (W0, 5)"
  "fetch t_wcode_adjust 5 Bk = (L, 6)"
  "fetch t_wcode_adjust 6 Oc = (R, 7)"
  "fetch t_wcode_adjust 6 Bk = (L, 6)"
  "fetch t_wcode_adjust 7 Bk = (W1, 2)"
  "fetch t_wcode_adjust 8 Bk = (L, 9)"
  "fetch t_wcode_adjust 8 Oc = (W0, 8)"
  "fetch t_wcode_adjust 9 Oc = (L, 10)"
  "fetch t_wcode_adjust 9 Bk = (L, 9)"
  "fetch t_wcode_adjust 10 Bk = (L, 11)"
  "fetch t_wcode_adjust 10 Oc = (L, 10)"
  "fetch t_wcode_adjust 11 Oc = (L, 11)"
  "fetch t_wcode_adjust 11 Bk = (R, 0)"
  by(auto simp: fetch.simps t_wcode_adjust_def nth_of.simps numeral)


fun wadjust_start :: "nat  nat  tape  bool"
  where
    "wadjust_start m rs (l, r) = 
         ( ln rn. l = Bk # Oc(Suc m) 
                   tl r = Oc # Bk(ln) @ Bk # Oc(Suc rs) @ Bk(rn))"

fun wadjust_loop_start :: "nat  nat  tape  bool"
  where
    "wadjust_loop_start m rs (l, r) = 
          ( ln rn ml mr. l = Oc(ml) @ Bk # Oc(Suc m)  
                          r = Oc # Bk(ln) @ Bk # Oc(mr) @ Bk(rn) 
                          ml + mr = Suc (Suc rs)  mr > 0)"

fun wadjust_loop_right_move :: "nat  nat  tape  bool"
  where
    "wadjust_loop_right_move m rs (l, r) = 
   ( ml mr nl nr rn. l = Bk(nl) @ Oc # Oc(ml) @ Bk # Oc(Suc m) 
                      r = Bk(nr) @ Oc(mr) @ Bk(rn) 
                      ml + mr = Suc (Suc rs)  mr > 0 
                      nl + nr > 0)"

fun wadjust_loop_check :: "nat  nat  tape  bool"
  where
    "wadjust_loop_check m rs (l, r) = 
  ( ml mr ln rn. l = Oc # Bk(ln) @ Bk # Oc # Oc(ml) @ Bk # Oc(Suc m) 
                  r = Oc(mr) @ Bk(rn)  ml + mr = (Suc rs))"

fun wadjust_loop_erase :: "nat  nat  tape  bool"
  where
    "wadjust_loop_erase m rs (l, r) = 
    ( ml mr ln rn. l = Bk(ln) @ Bk # Oc # Oc(ml) @ Bk # Oc(Suc m) 
                    tl r = Oc(mr) @ Bk(rn)  ml + mr = (Suc rs)  mr > 0)"

fun wadjust_loop_on_left_moving_O :: "nat  nat  tape  bool"
  where
    "wadjust_loop_on_left_moving_O m rs (l, r) = 
      ( ml mr ln rn. l = Oc(ml) @ Bk # Oc(Suc m )
                      r = Oc # Bk(ln) @ Bk # Bk # Oc(mr) @ Bk(rn) 
                      ml + mr = Suc rs  mr > 0)"

fun wadjust_loop_on_left_moving_B :: "nat  nat  tape  bool"
  where
    "wadjust_loop_on_left_moving_B m rs (l, r) = 
      ( ml mr nl nr rn. l = Bk(nl) @ Oc # Oc(ml) @ Bk # Oc(Suc m) 
                         r = Bk(nr) @ Bk # Bk # Oc(mr) @ Bk(rn)  
                         ml + mr = Suc rs  mr > 0)"

fun wadjust_loop_on_left_moving :: "nat  nat  tape  bool"
  where
    "wadjust_loop_on_left_moving m rs (l, r) = 
       (wadjust_loop_on_left_moving_O m rs (l, r) 
       wadjust_loop_on_left_moving_B m rs (l, r))"

fun wadjust_loop_right_move2 :: "nat  nat  tape  bool"
  where
    "wadjust_loop_right_move2 m rs (l, r) = 
        ( ml mr ln rn. l = Oc # Oc(ml) @ Bk # Oc(Suc m) 
                        r = Bk(ln) @ Bk # Bk # Oc(mr) @ Bk(rn) 
                        ml + mr = Suc rs  mr > 0)"

fun wadjust_erase2 :: "nat  nat  tape  bool"
  where
    "wadjust_erase2 m rs (l, r) = 
     ( ln rn. l = Bk(ln) @ Bk # Oc # Oc(Suc rs) @ Bk # Oc(Suc m) 
                     tl r = Bk(rn))"

fun wadjust_on_left_moving_O :: "nat  nat  tape  bool"
  where
    "wadjust_on_left_moving_O m rs (l, r) = 
        ( rn. l = Oc(Suc rs) @ Bk # Oc(Suc m) 
                  r = Oc # Bk(rn))"

fun wadjust_on_left_moving_B :: "nat  nat  tape  bool"
  where
    "wadjust_on_left_moving_B m rs (l, r) = 
         ( ln rn. l = Bk(ln) @ Oc # Oc(Suc rs) @ Bk # Oc(Suc m) 
                   r = Bk(rn))"

fun wadjust_on_left_moving :: "nat  nat  tape  bool"
  where
    "wadjust_on_left_moving m rs (l, r) = 
      (wadjust_on_left_moving_O m rs (l, r) 
       wadjust_on_left_moving_B m rs (l, r))"

fun wadjust_goon_left_moving_B :: "nat  nat  tape  bool"
  where 
    "wadjust_goon_left_moving_B m rs (l, r) = 
        ( rn. l = Oc(Suc m)  
               r = Bk # Oc(Suc (Suc rs)) @ Bk(rn))"

fun wadjust_goon_left_moving_O :: "nat  nat  tape  bool"
  where
    "wadjust_goon_left_moving_O m rs (l, r) = 
      ( ml mr rn. l = Oc(ml) @ Bk # Oc(Suc m) 
                      r = Oc(mr) @ Bk(rn)  
                      ml + mr = Suc (Suc rs)  mr > 0)"

fun wadjust_goon_left_moving :: "nat  nat  tape  bool"
  where
    "wadjust_goon_left_moving m rs (l, r) = 
            (wadjust_goon_left_moving_B m rs (l, r) 
             wadjust_goon_left_moving_O m rs (l, r))"

fun wadjust_backto_standard_pos_B :: "nat  nat  tape  bool"
  where
    "wadjust_backto_standard_pos_B m rs (l, r) =
        ( rn. l = []  
               r = Bk # Oc(Suc m )@ Bk # Oc(Suc (Suc rs)) @ Bk(rn))"

fun wadjust_backto_standard_pos_O :: "nat  nat  tape  bool"
  where
    "wadjust_backto_standard_pos_O m rs (l, r) = 
      ( ml mr rn. l = Oc(ml) 
                      r = Oc(mr) @ Bk # Oc(Suc (Suc rs)) @ Bk(rn)  
                      ml + mr = Suc m  mr > 0)"

fun wadjust_backto_standard_pos :: "nat  nat  tape  bool"
  where
    "wadjust_backto_standard_pos m rs (l, r) = 
        (wadjust_backto_standard_pos_B m rs (l, r)  
        wadjust_backto_standard_pos_O m rs (l, r))"

fun wadjust_stop :: "nat  nat  tape  bool"
  where
    "wadjust_stop m rs (l, r) =
        ( rn. l = [Bk]  
               r = Oc(Suc m )@ Bk # Oc(Suc (Suc rs)) @ Bk(rn))"

declare wadjust_start.simps[simp del]  wadjust_loop_start.simps[simp del]
  wadjust_loop_right_move.simps[simp del]  wadjust_loop_check.simps[simp del]
  wadjust_loop_erase.simps[simp del] wadjust_loop_on_left_moving.simps[simp del]
  wadjust_loop_right_move2.simps[simp del] wadjust_erase2.simps[simp del]
  wadjust_on_left_moving_O.simps[simp del] wadjust_on_left_moving_B.simps[simp del]
  wadjust_on_left_moving.simps[simp del] wadjust_goon_left_moving_B.simps[simp del]
  wadjust_goon_left_moving_O.simps[simp del] wadjust_goon_left_moving.simps[simp del]
  wadjust_backto_standard_pos.simps[simp del] wadjust_backto_standard_pos_B.simps[simp del]
  wadjust_backto_standard_pos_O.simps[simp del] wadjust_stop.simps[simp del]

fun wadjust_inv :: "nat  nat  nat  tape  bool"
  where
    "wadjust_inv st m rs (l, r) = 
       (if st = Suc 0 then wadjust_start m rs (l, r) 
        else if st = Suc (Suc 0) then wadjust_loop_start m rs (l, r)
        else if st = Suc (Suc (Suc 0)) then wadjust_loop_right_move m rs (l, r)
        else if st = 4 then wadjust_loop_check m rs (l, r)
        else if st = 5 then wadjust_loop_erase m rs (l, r)
        else if st = 6 then wadjust_loop_on_left_moving m rs (l, r)
        else if st = 7 then wadjust_loop_right_move2 m rs (l, r)
        else if st = 8 then wadjust_erase2 m rs (l, r)
        else if st = 9 then wadjust_on_left_moving m rs (l, r)
        else if st = 10 then wadjust_goon_left_moving m rs (l, r)
        else if st = 11 then wadjust_backto_standard_pos m rs (l, r)
        else if st = 0 then wadjust_stop m rs (l, r)
        else False
)"

declare wadjust_inv.simps[simp del]

fun wadjust_phase :: "nat  config  nat"
  where
    "wadjust_phase rs (st, l, r) = 
         (if st = 1 then 3 
          else if st  2  st  7 then 2
          else if st  8  st  11 then 1
          else 0)"

fun wadjust_stage :: "nat  config  nat"
  where
    "wadjust_stage rs (st, l, r) = 
           (if st  2  st  7 then 
                  rs - length (takeWhile (λ a. a = Oc) 
                          (tl (dropWhile (λ a. a = Oc) (rev l @ r))))
            else 0)"

fun wadjust_state :: "nat  config  nat"
  where
    "wadjust_state rs (st, l, r) = 
       (if st  2  st  7 then 8 - st
        else if st  8  st  11 then 12 - st
        else 0)"

fun wadjust_step :: "nat  config  nat"
  where
    "wadjust_step rs (st, l, r) = 
       (if st = 1 then (if hd r = Bk then 1
                        else 0) 
        else if st = 3 then length r
        else if st = 5 then (if hd r = Oc then 1
                             else 0)
        else if st = 6 then length l
        else if st = 8 then (if hd r = Oc then 1
                             else 0)
        else if st = 9 then length l
        else if st = 10 then length l
        else if st = 11 then (if hd r = Bk then 0
                              else Suc (length l))
        else 0)"

fun wadjust_measure :: "(nat × config)  nat × nat × nat × nat"
  where
    "wadjust_measure (rs, (st, l, r)) = 
     (wadjust_phase rs (st, l, r), 
      wadjust_stage rs (st, l, r),
      wadjust_state rs (st, l, r), 
      wadjust_step rs (st, l, r))"

definition wadjust_le :: "((nat × config) × nat × config) set"
  where "wadjust_le  (inv_image lex_square wadjust_measure)"

lemma wf_lex_square[intro]: "wf lex_square"
  by(auto intro:wf_lex_prod simp: Abacus.lex_pair_def lex_square_def 
      Abacus.lex_triple_def)

lemma wf_wadjust_le[intro]: "wf wadjust_le"
  by(auto intro:wf_inv_image simp: wadjust_le_def
      Abacus.lex_triple_def Abacus.lex_pair_def)

lemma wadjust_start_snd_nonempty[simp]: "wadjust_start m rs (c, []) = False"
  apply(auto simp: wadjust_start.simps)
  done

lemma wadjust_loop_right_move_fst_nonempty[simp]: "wadjust_loop_right_move m rs (c, [])  c  []"
  apply(auto simp: wadjust_loop_right_move.simps)
  done

lemma wadjust_loop_check_fst_nonempty[simp]: "wadjust_loop_check m rs (c, [])  c  []"
  apply(simp only: wadjust_loop_check.simps, auto)
  done

lemma wadjust_loop_start_snd_nonempty[simp]: "wadjust_loop_start m rs (c, []) = False"
  apply(simp add: wadjust_loop_start.simps)
  done

lemma wadjust_erase2_singleton[simp]: "wadjust_loop_check m rs (c, [])  wadjust_erase2 m rs (tl c, [hd c])"
  apply(simp only: wadjust_loop_check.simps wadjust_erase2.simps, auto)
  done

lemma wadjust_loop_on_left_moving_snd_nonempty[simp]:
  "wadjust_loop_on_left_moving m rs (c, []) = False"
  "wadjust_loop_right_move2 m rs (c, []) = False"
  "wadjust_erase2 m rs ([], []) = False"
  by(auto simp: wadjust_loop_on_left_moving.simps
      wadjust_loop_right_move2.simps
      wadjust_erase2.simps)

lemma wadjust_on_left_moving_B_Bk1[simp]: "wadjust_on_left_moving_B m rs 
                 (Oc # Oc # Oc(rs) @ Bk # Oc # Oc(m), [Bk])"
  apply(simp add: wadjust_on_left_moving_B.simps, auto)
  done

lemma wadjust_on_left_moving_B_Bk2[simp]: "wadjust_on_left_moving_B m rs 
                 (Bk(n) @ Bk # Oc # Oc # Oc(rs) @ Bk # Oc # Oc(m), [Bk])"
  apply(simp add: wadjust_on_left_moving_B.simps , auto)
  apply(rule_tac x = "Suc n" in exI, simp add: exp_ind del: replicate_Suc)
  done

lemma wadjust_on_left_moving_singleton[simp]: "wadjust_erase2 m rs (c, []); c  [] 
            wadjust_on_left_moving m rs (tl c, [hd c])" unfolding wadjust_erase2.simps
  apply(auto simp add: wadjust_on_left_moving.simps)
   apply (metis (no_types, lifting) empty_replicate hd_append hd_replicate list.sel(1) list.sel(3)
      self_append_conv2 tl_append2 tl_replicate
      wadjust_on_left_moving_B_Bk1 wadjust_on_left_moving_B_Bk2)+
  done

lemma wadjust_erase2_cases[simp]: "wadjust_erase2 m rs (c, [])
     (c = []  wadjust_on_left_moving m rs ([], [Bk]))  
       (c  []  wadjust_on_left_moving m rs (tl c, [hd c]))"
  apply(auto)
  done

lemma wadjust_on_left_moving_nonempty[simp]:
  "wadjust_on_left_moving m rs ([], []) = False"
  "wadjust_on_left_moving_O m rs (c, []) = False"
   apply(auto simp: wadjust_on_left_moving.simps 
      wadjust_on_left_moving_O.simps wadjust_on_left_moving_B.simps)
  done

lemma wadjust_on_left_moving_B_singleton_Bk[simp]:
  " wadjust_on_left_moving_B m rs (c, []); c  []; hd c = Bk 
                                      wadjust_on_left_moving_B m rs (tl c, [Bk])"
  apply(auto simp add: wadjust_on_left_moving_B.simps hd_append)
  by (metis cell.distinct(1) empty_replicate list.sel(1) tl_append2 tl_replicate)

lemma wadjust_on_left_moving_B_singleton_Oc[simp]:
  "wadjust_on_left_moving_B m rs (c, []); c  []; hd c = Oc 
                                  wadjust_on_left_moving_O m rs (tl c, [Oc])"
  apply(auto simp add: wadjust_on_left_moving_B.simps wadjust_on_left_moving_O.simps hd_append)
   apply (metis cell.distinct(1) empty_replicate hd_replicate list.sel(3) self_append_conv2)+
  done

lemma wadjust_on_left_moving_singleton2[simp]:
  "wadjust_on_left_moving m rs (c, []); c  []  
  wadjust_on_left_moving m rs (tl c, [hd c])"
  apply(simp add: wadjust_on_left_moving.simps)
  apply(case_tac "hd c", simp_all)
  done

lemma wadjust_nonempty[simp]: "wadjust_goon_left_moving m rs (c, []) = False"
  "wadjust_backto_standard_pos m rs (c, []) = False"
  by(auto simp: wadjust_goon_left_moving.simps wadjust_goon_left_moving_B.simps
      wadjust_goon_left_moving_O.simps wadjust_backto_standard_pos.simps
      wadjust_backto_standard_pos_B.simps wadjust_backto_standard_pos_O.simps)

lemma wadjust_loop_start_no_Bk[simp]: "wadjust_loop_start m rs (c, Bk # list) = False"
  apply(auto simp: wadjust_loop_start.simps)
  done

lemma wadjust_loop_check_nonempty[simp]: "wadjust_loop_check m rs (c, b)  c  []"
  apply(simp only: wadjust_loop_check.simps, auto)
  done

lemma wadjust_erase2_via_loop_check_Bk[simp]: "wadjust_loop_check m rs (c, Bk # list)
                wadjust_erase2 m rs (tl c, hd c # Bk # list)"
  by (auto simp: wadjust_loop_check.simps wadjust_erase2.simps)

declare wadjust_loop_on_left_moving_O.simps[simp del]
  wadjust_loop_on_left_moving_B.simps[simp del]

lemma wadjust_loop_on_left_moving_B_via_erase[simp]: "wadjust_loop_erase m rs (c, Bk # list); hd c = Bk
     wadjust_loop_on_left_moving_B m rs (tl c, Bk # Bk # list)"
  unfolding wadjust_loop_erase.simps wadjust_loop_on_left_moving_B.simps
  apply(erule_tac exE)+
  apply(rename_tac ml mr ln rn)
  apply(rule_tac x = ml in exI, rule_tac x = mr in exI, 
      rule_tac x = ln in exI, rule_tac x = 0 in exI)
  apply(case_tac ln, auto)
  apply(simp add: exp_ind [THEN sym])
  done

lemma wadjust_loop_on_left_moving_O_Bk_via_erase[simp]:
  "wadjust_loop_erase m rs (c, Bk # list); c  []; hd c = Oc 
             wadjust_loop_on_left_moving_O m rs (tl c, Oc # Bk # list)"
  apply(auto simp: wadjust_loop_erase.simps wadjust_loop_on_left_moving_O.simps)
  by (metis cell.distinct(1) empty_replicate hd_append hd_replicate list.sel(1))

lemma wadjust_loop_on_left_moving_Bk_via_erase[simp]: "wadjust_loop_erase m rs (c, Bk # list); c  []  
                wadjust_loop_on_left_moving m rs (tl c, hd c # Bk # list)"
  apply(case_tac "hd c", simp_all add:wadjust_loop_on_left_moving.simps)
  done


lemma wadjust_loop_on_left_moving_B_Bk_move[simp]:
  "wadjust_loop_on_left_moving_B m rs (c, Bk # list); hd c = Bk
      wadjust_loop_on_left_moving_B m rs (tl c, Bk # Bk # list)"
  apply(simp only: wadjust_loop_on_left_moving_B.simps)
  apply(erule_tac exE)+
  by (metis (no_types, lifting) cell.distinct(1) list.sel(1)
      replicate_Suc_iff_anywhere self_append_conv2 tl_append2 tl_replicate)

lemma wadjust_loop_on_left_moving_O_Oc_move[simp]:
  "wadjust_loop_on_left_moving_B m rs (c, Bk # list); hd c = Oc
     wadjust_loop_on_left_moving_O m rs (tl c, Oc # Bk # list)"
  apply(simp only: wadjust_loop_on_left_moving_O.simps 
      wadjust_loop_on_left_moving_B.simps)
  by (metis cell.distinct(1) empty_replicate hd_append hd_replicate list.sel(3) self_append_conv2)


lemma wadjust_loop_erase_nonempty[simp]: "wadjust_loop_erase m rs (c, b)  c  []"
  "wadjust_loop_on_left_moving m rs (c, b)  c  []"
  "wadjust_loop_right_move2 m rs (c, b)  c  []"
  "wadjust_erase2 m rs (c, Bk # list)  c  []"
  "wadjust_on_left_moving m rs (c,b)  c  []"
  "wadjust_on_left_moving_O m rs (c, Bk # list) = False"
  "wadjust_goon_left_moving m rs (c, b)  c  []"
  "wadjust_loop_on_left_moving_O m rs (c, Bk # list) = False"
  by(auto simp: wadjust_loop_erase.simps wadjust_loop_on_left_moving.simps 
      wadjust_loop_on_left_moving_O.simps wadjust_loop_on_left_moving_B.simps
      wadjust_loop_right_move2.simps wadjust_erase2.simps
      wadjust_on_left_moving.simps
      wadjust_on_left_moving_O.simps
      wadjust_on_left_moving_B.simps wadjust_goon_left_moving.simps
      wadjust_goon_left_moving_B.simps
      wadjust_goon_left_moving_O.simps)

lemma wadjust_loop_on_left_moving_Bk_move[simp]:
  "wadjust_loop_on_left_moving m rs (c, Bk # list)
             wadjust_loop_on_left_moving m rs (tl c, hd c # Bk # list)"
  apply(simp add: wadjust_loop_on_left_moving.simps)
  apply(case_tac "hd c", simp_all)
  done

lemma wadjust_loop_start_Oc_via_Bk_move[simp]: 
  "wadjust_loop_right_move2 m rs (c, Bk # list)   wadjust_loop_start m rs (c, Oc # list)"
  apply(auto simp: wadjust_loop_right_move2.simps wadjust_loop_start.simps replicate_app_Cons_same)
  by (metis add_Suc replicate_Suc)

lemma wadjust_on_left_moving_Bk_via_erase[simp]: "wadjust_erase2 m rs (c, Bk # list)  
                 wadjust_on_left_moving m rs (tl c, hd c # Bk # list)"
  apply(auto simp: wadjust_erase2.simps wadjust_on_left_moving.simps replicate_app_Cons_same
      wadjust_on_left_moving_O.simps wadjust_on_left_moving_B.simps)
   apply (metis exp_ind replicate_append_same)+
  done


lemma wadjust_on_left_moving_B_Bk_drop_one: "wadjust_on_left_moving_B m rs (c, Bk # list); hd c = Bk
     wadjust_on_left_moving_B m rs (tl c, Bk # Bk # list)"
  apply(auto simp: wadjust_on_left_moving_B.simps)
  by (metis cell.distinct(1) hd_append list.sel(1) tl_append2 tl_replicate)

lemma wadjust_on_left_moving_B_Bk_drop_Oc: "wadjust_on_left_moving_B m rs (c, Bk # list); hd c = Oc
     wadjust_on_left_moving_O m rs (tl c, Oc # Bk # list)"
  apply(auto simp: wadjust_on_left_moving_O.simps wadjust_on_left_moving_B.simps)
  by (metis cell.distinct(1) empty_replicate hd_append hd_replicate list.sel(3) self_append_conv2)

lemma wadjust_on_left_moving_B_drop[simp]: "wadjust_on_left_moving  m rs (c, Bk # list)   
                  wadjust_on_left_moving m rs (tl c, hd c # Bk # list)"
  by(cases "hd c", auto simp:wadjust_on_left_moving.simps wadjust_on_left_moving_B_Bk_drop_one
      wadjust_on_left_moving_B_Bk_drop_Oc)

lemma wadjust_goon_left_moving_O_no_Bk[simp]: "wadjust_goon_left_moving_O m rs (c, Bk # list) = False"
  by (auto simp add: wadjust_goon_left_moving_O.simps)

lemma wadjust_backto_standard_pos_via_left_Bk[simp]:
  "wadjust_goon_left_moving m rs (c, Bk # list) 
  wadjust_backto_standard_pos m rs (tl c, hd c # Bk # list)"
  by(case_tac "hd c", simp_all add: wadjust_backto_standard_pos.simps wadjust_goon_left_moving.simps
      wadjust_goon_left_moving_B.simps wadjust_backto_standard_pos_O.simps)

lemma wadjust_loop_right_move_Oc[simp]:
  "wadjust_loop_start m rs (c, Oc # list)  wadjust_loop_right_move m rs (Oc # c, list)"
  apply(auto simp add: wadjust_loop_start.simps wadjust_loop_right_move.simps
      simp del:split_head_repeat)
  apply(rename_tac ln rn ml mr)
  apply(rule_tac x = ml in exI, rule_tac x = mr in exI, 
      rule_tac x = 0 in exI, simp)
  apply(rule_tac x = "Suc ln" in exI, simp add: exp_ind del: replicate_Suc)
  done

lemma wadjust_loop_check_Oc[simp]:
  assumes "wadjust_loop_right_move m rs (c, Oc # list)" 
  shows "wadjust_loop_check m rs (Oc # c, list)"
proof -
  from assms obtain ml mr nl nr rn
    where "c = Bk  nl @ Oc # Oc  ml @ Bk # Oc  m @ [Oc]"
      "Oc # list = Bk  nr @ Oc  mr @ Bk  rn"
      "ml + mr = Suc (Suc rs)" "0 < mr" "0 < nl + nr"
    unfolding wadjust_loop_right_move.simps exp_ind 
      wadjust_loop_check.simps by auto
  hence "ln. Oc # c = Oc # Bk  ln @ Bk # Oc # Oc  ml @ Bk # Oc  Suc m"
    "rn. list = Oc  (mr - 1) @ Bk  rn" "ml + (mr - 1) = Suc rs"
    by(cases nl;cases nr;cases mr;force simp add: wadjust_loop_right_move.simps exp_ind 
        wadjust_loop_check.simps replicate_append_same)+
  thus ?thesis unfolding wadjust_loop_check.simps by auto
qed

lemma wadjust_loop_erase_move_Oc[simp]: "wadjust_loop_check m rs (c, Oc # list)  
               wadjust_loop_erase m rs (tl c, hd c # Oc # list)"
  apply(simp only: wadjust_loop_check.simps wadjust_loop_erase.simps)
  apply(erule_tac exE)+
  using Cons_replicate_eq by fastforce

lemma wadjust_loop_on_move_no_Oc[simp]:
  "wadjust_loop_on_left_moving_B m rs (c, Oc # list) = False"
  "wadjust_loop_right_move2 m rs (c, Oc # list) = False"
  "wadjust_loop_on_left_moving m rs (c, Oc # list)
            wadjust_loop_right_move2 m rs (Oc # c, list)"
  "wadjust_on_left_moving_B m rs (c, Oc # list) = False"
  "wadjust_loop_erase m rs (c, Oc # list)  
                wadjust_loop_erase m rs (c, Bk # list)"
  by(auto simp: wadjust_loop_on_left_moving_B.simps wadjust_loop_on_left_moving_O.simps
      wadjust_loop_right_move2.simps replicate_app_Cons_same wadjust_loop_on_left_moving.simps
      wadjust_on_left_moving_B.simps wadjust_loop_erase.simps)

lemma wadjust_goon_left_moving_B_Bk_Oc: "wadjust_on_left_moving_O m rs (c, Oc # list); hd c = Bk  
         wadjust_goon_left_moving_B m rs (tl c, Bk # Oc # list)"
  apply(auto simp: wadjust_on_left_moving_O.simps 
      wadjust_goon_left_moving_B.simps )
  done

lemma wadjust_goon_left_moving_O_Oc_Oc: "wadjust_on_left_moving_O m rs (c, Oc # list); hd c = Oc
     wadjust_goon_left_moving_O m rs (tl c, Oc # Oc # list)"
  apply(auto simp: wadjust_on_left_moving_O.simps 
      wadjust_goon_left_moving_O.simps )
  apply(auto simp:  numeral_2_eq_2)
  done


lemma wadjust_goon_left_moving_Oc[simp]: "wadjust_on_left_moving m rs (c, Oc # list)  
              wadjust_goon_left_moving m rs (tl c, hd c # Oc # list)"
  by(cases "hd c"; force simp: wadjust_on_left_moving.simps wadjust_goon_left_moving.simps
      wadjust_goon_left_moving_B_Bk_Oc wadjust_goon_left_moving_O_Oc_Oc)+

lemma left_moving_Bk_Oc[simp]: "wadjust_goon_left_moving_O m rs (c, Oc # list); hd c = Bk 
                wadjust_goon_left_moving_B m rs (tl c, Bk # Oc # list)"
  apply(auto simp: wadjust_goon_left_moving_O.simps wadjust_goon_left_moving_B.simps hd_append
      dest!: gr0_implies_Suc)
   apply (metis cell.distinct(1) empty_replicate hd_replicate list.sel(3) self_append_conv2)
  by (metis add_cancel_right_left cell.distinct(1) hd_replicate replicate_Suc_iff_anywhere)

lemma  left_moving_Oc_Oc[simp]: "wadjust_goon_left_moving_O m rs (c, Oc # list); hd c = Oc  
  wadjust_goon_left_moving_O m rs (tl c, Oc # Oc # list)"
  apply(auto simp: wadjust_goon_left_moving_O.simps wadjust_goon_left_moving_B.simps)
  apply(rename_tac mlx mrx rnx)
  apply(rule_tac x = "mlx - 1" in exI, simp)
  apply(case_tac mlx, simp_all add: )
  apply(rule_tac x = "Suc mrx" in exI, auto simp: )
  done

lemma wadjust_goon_left_moving_B_no_Oc[simp]:
  "wadjust_goon_left_moving_B m rs (c, Oc # list) = False"
  apply(auto simp: wadjust_goon_left_moving_B.simps)
  done

lemma wadjust_goon_left_moving_Oc_move[simp]: "wadjust_goon_left_moving m rs (c, Oc # list)  
  wadjust_goon_left_moving m rs (tl c, hd c # Oc # list)"
  by(cases "hd c",auto simp: wadjust_goon_left_moving.simps)

lemma wadjust_backto_standard_pos_B_no_Oc[simp]:
  "wadjust_backto_standard_pos_B m rs (c, Oc # list) = False"
  apply(simp add: wadjust_backto_standard_pos_B.simps)
  done

lemma wadjust_backto_standard_pos_O_no_Bk[simp]:
  "wadjust_backto_standard_pos_O m rs (c, Bk # xs) = False"
  by(simp add: wadjust_backto_standard_pos_O.simps)

lemma wadjust_backto_standard_pos_B_Bk_Oc[simp]:
  "wadjust_backto_standard_pos_O m rs ([], Oc # list)  
  wadjust_backto_standard_pos_B m rs ([], Bk # Oc # list)"
  apply(auto simp: wadjust_backto_standard_pos_O.simps
      wadjust_backto_standard_pos_B.simps)
  done

lemma wadjust_backto_standard_pos_B_Bk_Oc_via_O[simp]: 
  "wadjust_backto_standard_pos_O m rs (c, Oc # list); c  []; hd c = Bk
   wadjust_backto_standard_pos_B m rs (tl c, Bk # Oc # list)"
  apply(simp add:wadjust_backto_standard_pos_O.simps 
      wadjust_backto_standard_pos_B.simps, auto)
  done 

lemma wadjust_backto_standard_pos_B_Oc_Oc_via_O[simp]: "wadjust_backto_standard_pos_O m rs (c, Oc # list); c  []; hd c = Oc
            wadjust_backto_standard_pos_O m rs (tl c, Oc # Oc # list)"
  apply(simp add: wadjust_backto_standard_pos_O.simps, auto)
  by force

lemma wadjust_backto_standard_pos_cases[simp]: "wadjust_backto_standard_pos m rs (c, Oc # list)
   (c = []  wadjust_backto_standard_pos m rs ([], Bk # Oc # list))  
 (c  []  wadjust_backto_standard_pos m rs (tl c, hd c # Oc # list))"
  apply(auto simp: wadjust_backto_standard_pos.simps)
  apply(case_tac "hd c", simp_all)
  done

lemma wadjust_loop_right_move_nonempty_snd[simp]: "wadjust_loop_right_move m rs (c, []) = False"
proof -
  {fix nl ml mr rn nr
    have "(c = Bk  nl @ Oc # Oc  ml @ Bk # Oc  Suc m 
        [] = Bk  nr @ Oc  mr @ Bk  rn  ml + mr = Suc (Suc rs)  0 < mr  0 < nl + nr) =
    False" by auto
  } note t=this
  thus ?thesis unfolding wadjust_loop_right_move.simps t by blast
qed

lemma wadjust_loop_erase_nonempty_snd[simp]: "wadjust_loop_erase m rs (c, []) = False"
  apply(simp only: wadjust_loop_erase.simps, auto)
  done

lemma wadjust_loop_erase_cases2[simp]: "Suc (Suc rs) = a;  wadjust_loop_erase m rs (c, Bk # list)
   a - length (takeWhile (λa. a = Oc) (tl (dropWhile (λa. a = Oc) (rev (tl c) @ hd c # Bk # list))))
  < a - length (takeWhile (λa. a = Oc) (tl (dropWhile (λa. a = Oc) (rev c @ Bk # list)))) 
  a - length (takeWhile (λa. a = Oc) (tl (dropWhile (λa. a = Oc) (rev (tl c) @ hd c # Bk # list)))) =
  a - length (takeWhile (λa. a = Oc) (tl (dropWhile (λa. a = Oc) (rev c @ Bk # list))))"
  apply(simp only: wadjust_loop_erase.simps)
  apply(rule_tac disjI2)
  apply(case_tac c, simp, simp)
  done

lemma dropWhile_exp1: "dropWhile (λa. a = Oc) (Oc(n) @ xs) = dropWhile (λa. a = Oc) xs"
  apply(induct n, simp_all add: )
  done
lemma takeWhile_exp1: "takeWhile (λa. a = Oc) (Oc(n) @ xs) = Oc(n) @ takeWhile (λa. a = Oc) xs"
  apply(induct n, simp_all add: )
  done

lemma wadjust_correctness_helper_1:
  assumes "Suc (Suc rs) = a" " wadjust_loop_right_move2 m rs (c, Bk # list)"
  shows "a - length (takeWhile (λa. a = Oc) (tl (dropWhile (λa. a = Oc) (rev c @ Oc # list))))
                 < a - length (takeWhile (λa. a = Oc) (tl (dropWhile (λa. a = Oc) (rev c @ Bk # list))))"
proof -
  have "ml + mr = Suc rs  0 < mr 
       rs - (ml + length (takeWhile (λa. a = Oc) list))
       < Suc rs -
         (ml +
          length
           (takeWhile (λa. a = Oc)
             (Bk  ln @ Bk # Bk # Oc  mr @ Bk  rn))) "
    for ml mr ln rn
    by(cases ln, auto)
  thus ?thesis using assms
    by (auto simp: wadjust_loop_right_move2.simps dropWhile_exp1 takeWhile_exp1)
qed

lemma wadjust_correctness_helper_2:
  "Suc (Suc rs) = a;  wadjust_loop_on_left_moving m rs (c, Bk # list)
   a - length (takeWhile (λa. a = Oc) (tl (dropWhile (λa. a = Oc) (rev (tl c) @ hd c # Bk # list))))
  < a - length (takeWhile (λa. a = Oc) (tl (dropWhile (λa. a = Oc) (rev c @ Bk # list)))) 
  a - length (takeWhile (λa. a = Oc) (tl (dropWhile (λa. a = Oc) (rev (tl c) @ hd c # Bk # list)))) =
  a - length (takeWhile (λa. a = Oc) (tl (dropWhile (λa. a = Oc) (rev c @ Bk # list))))"
  apply(subgoal_tac "c  []")
   apply(case_tac c, simp_all)
  done

lemma wadjust_loop_check_empty_false[simp]: "wadjust_loop_check m rs ([], b) = False"
  apply(simp add: wadjust_loop_check.simps)
  done

lemma wadjust_loop_check_cases: "Suc (Suc rs) = a;  wadjust_loop_check m rs (c, Oc # list)
   a - length (takeWhile (λa. a = Oc) (tl (dropWhile (λa. a = Oc) (rev (tl c) @ hd c # Oc # list))))
  < a - length (takeWhile (λa. a = Oc) (tl (dropWhile (λa. a = Oc) (rev c @ Oc # list)))) 
  a - length (takeWhile (λa. a = Oc) (tl (dropWhile (λa. a = Oc) (rev (tl c) @ hd c # Oc # list)))) =
  a - length (takeWhile (λa. a = Oc) (tl (dropWhile (λa. a = Oc) (rev c @ Oc # list))))"
  apply(case_tac "c", simp_all)
  done

lemma wadjust_loop_erase_cases_or: 
  "Suc (Suc rs) = a;  wadjust_loop_erase m rs (c, Oc # list)
   a - length (takeWhile (λa. a = Oc) (tl (dropWhile (λa. a = Oc) (rev c @ Bk # list))))
  < a - length (takeWhile (λa. a = Oc) (tl (dropWhile (λa. a = Oc) (rev c @ Oc # list)))) 
  a - length (takeWhile (λa. a = Oc) (tl (dropWhile (λa. a = Oc) (rev c @ Bk # list)))) =
  a - length (takeWhile (λa. a = Oc) (tl (dropWhile (λa. a = Oc) (rev c @ Oc # list))))"
  apply(simp add: wadjust_loop_erase.simps)
  apply(rule_tac disjI2)
  apply(auto)
  apply(simp add: dropWhile_exp1 takeWhile_exp1)
  done

lemmas wadjust_correctness_helpers = wadjust_correctness_helper_2 wadjust_correctness_helper_1 wadjust_loop_erase_cases_or wadjust_loop_check_cases

declare numeral_2_eq_2[simp del]

lemma wadjust_start_Oc[simp]: "wadjust_start m rs (c, Bk # list)
        wadjust_start m rs (c, Oc # list)"
  apply(auto simp: wadjust_start.simps)
  done

lemma wadjust_stop_Bk[simp]: "wadjust_backto_standard_pos m rs (c, Bk # list)
        wadjust_stop m rs (Bk # c, list)"
  apply(auto simp: wadjust_backto_standard_pos.simps 
      wadjust_stop.simps wadjust_backto_standard_pos_B.simps)
  done

lemma wadjust_loop_start_Oc[simp]:
  assumes "wadjust_start m rs (c, Oc # list)"
  shows "wadjust_loop_start m rs (Oc # c, list)"
proof -
  from assms[unfolded wadjust_start.simps] obtain ln rn where
    "c = Bk # Oc # Oc  m" "list = Oc # Bk  ln @ Bk # Oc # Oc  rs @ Bk  rn"
    by(auto)
  hence "Oc # c = Oc  1 @ Bk # Oc  Suc m 
       list = Oc # Bk  ln @ Bk # Oc Suc rs @ Bk  rn  1 + (Suc rs) = Suc (Suc rs)  0 < Suc rs"
    by auto
  thus ?thesis unfolding wadjust_loop_start.simps by blast
qed

lemma erase2_Bk_if_Oc[simp]:" wadjust_erase2 m rs (c, Oc # list)
        wadjust_erase2 m rs (c, Bk # list)"
  apply(auto simp: wadjust_erase2.simps)
  done

lemma wadjust_loop_right_move_Bk[simp]: "wadjust_loop_right_move m rs (c, Bk # list)
     wadjust_loop_right_move m rs (Bk # c, list)"
  apply(simp only: wadjust_loop_right_move.simps)
  apply(erule_tac exE)+
  apply auto
   apply (metis cell.distinct(1) empty_replicate hd_append hd_replicate less_SucI
      list.sel(1) list.sel(3) neq0_conv replicate_Suc_iff_anywhere tl_append2 tl_replicate)+
  done

lemma wadjust_correctness:
  shows "let P = (λ (len, st, l, r). st = 0) in 
  let Q = (λ (len, st, l, r). wadjust_inv st m rs (l, r)) in 
  let f = (λ stp. (Suc (Suc rs),  steps0 (Suc 0, Bk # Oc(Suc m), 
                Bk # Oc # Bk(ln) @ Bk #  Oc(Suc rs) @ Bk(rn)) t_wcode_adjust stp)) in
     n .P (f n)  Q (f n)"
proof -
  let ?P = "(λ (len, st, l, r). st = 0)"
  let ?Q = "λ (len, st, l, r). wadjust_inv st m rs (l, r)"
  let ?f = "λ stp. (Suc (Suc rs),  steps0 (Suc 0, Bk # Oc(Suc m), 
                Bk # Oc # Bk(ln) @ Bk # Oc(Suc rs) @ Bk(rn)) t_wcode_adjust stp)"
  have " n. ?P (?f n)  ?Q (?f n)"
  proof(rule_tac halt_lemma2)
    show "wf wadjust_le" by auto
  next
    { fix n assume a:"¬ ?P (?f n)  ?Q (?f n)"
      have "?Q (?f (Suc n))  (?f (Suc n), ?f n)  wadjust_le"
      proof(cases "?f n")
        case (fields a b c d)
        then show ?thesis proof(cases d)
          case Nil
          then show ?thesis using a fields apply(simp add: step.simps)
            apply(simp_all only: wadjust_inv.simps split: if_splits)
                        apply(simp_all add: wadjust_inv.simps wadjust_le_def
                wadjust_correctness_helpers
                Abacus.lex_triple_def Abacus.lex_pair_def lex_square_def  split: if_splits).
        next
          case (Cons aa list)
          then show ?thesis using a fields Nil Cons
            apply((case_tac aa); simp add: step.simps)
             apply(simp_all only: wadjust_inv.simps split: if_splits)
                                apply(simp_all)
                               apply(simp_all add: wadjust_inv.simps wadjust_le_def
                wadjust_correctness_helpers
                Abacus.lex_triple_def Abacus.lex_pair_def lex_square_def  split: if_splits).
        qed
      qed
    }
    thus " n. ¬ ?P (?f n)  ?Q (?f n)  
                 ?Q (?f (Suc n))  (?f (Suc n), ?f n)  wadjust_le" by auto
  next
    show "?Q (?f 0)" by(auto simp add: steps.simps wadjust_inv.simps wadjust_start.simps)
  next
    show "¬ ?P (?f 0)" by (simp add: steps.simps)
  qed
  thus"?thesis" by simp
qed

lemma tm_wf_t_wcode_adjust[intro]: "tm_wf (t_wcode_adjust, 0)"
  by(auto simp: t_wcode_adjust_def tm_wf.simps)

lemma bl_bin_nonzero[simp]: "args  []  bl_bin (<args::nat list>) > 0"
  by(cases args)
    (auto simp: tape_of_nl_cons bl_bin.simps)

lemma wcode_lemma_pre':
  "args  []  
   stp rn. steps0 (Suc 0, [], <m # args>) 
              ((t_wcode_prepare |+| t_wcode_main) |+| t_wcode_adjust) stp
  = (0,  [Bk],  Oc(Suc m) @ Bk # Oc(Suc (bl_bin (<args>))) @ Bk(rn))" 
proof -
  let ?P1 = "λ (l, r). l = []  r = <m # args>"
  let ?Q1 = "λ(l, r). l = Bk # Oc(Suc m) 
    (ln rn. r = Bk # Oc # Bk(ln) @ Bk # Bk # Oc(bl_bin (<args>)) @ Bk(rn))"
  let ?P2 = ?Q1
  let ?Q2 = "λ (l, r). (wadjust_stop m (bl_bin (<args>) - 1) (l, r))"
  let ?P3 = "λ tp. False"
  assume h: "args  []"
  hence a: "bl_bin (<args>) > 0"
    using h by simp
  hence "{?P1} (t_wcode_prepare |+| t_wcode_main) |+| t_wcode_adjust {?Q2}"
  proof(rule_tac Hoare_plus_halt)
  next
    show "tm_wf (t_wcode_prepare |+| t_wcode_main, 0)"
      by(rule_tac tm_comp_wf, auto)
  next
    show "{?P1} t_wcode_prepare |+| t_wcode_main {?Q1}"
    proof(rule_tac Hoare_haltI, auto)
      show 
        "n. is_final (steps0 (Suc 0, [], <m # args>) (t_wcode_prepare |+| t_wcode_main) n) 
        (λ(l, r). l = Bk # Oc # Oc  m 
        (ln rn. r = Bk # Oc # Bk  ln @ Bk # Bk # Oc  bl_bin (<args>) @ Bk  rn))
        holds_for steps0 (Suc 0, [], <m # args>) (t_wcode_prepare |+| t_wcode_main) n"
        using h prepare_mainpart_lemma[of args m]
        apply(auto) apply(rename_tac stp ln rn)
        apply(rule_tac x = stp in exI, simp)
        apply(rule_tac x = ln in exI, auto)
        done
    qed
  next
    show "{?P2} t_wcode_adjust {?Q2}"
    proof(rule_tac Hoare_haltI, auto del: replicate_Suc)
      fix ln rn
      obtain n a b where "steps0
        (Suc 0, Bk # Oc  m @ [Oc],
         Bk # Oc # Bk  ln @ Bk # Bk # Oc  (bl_bin (<args>) - Suc 0) @ Oc # Bk  rn)
        t_wcode_adjust n = (0, a, b)"
        "wadjust_inv 0 m (bl_bin (<args>) - Suc 0) (a, b)"
        using wadjust_correctness[of m "bl_bin (<args>) - 1" "Suc ln" rn,unfolded Let_def]
        by(simp del: replicate_Suc add: replicate_Suc[THEN sym] exp_ind, auto)
      thus "n. is_final (steps0 (Suc 0, Bk # Oc # Oc  m, 
        Bk # Oc # Bk  ln @ Bk # Bk # Oc  bl_bin (<args>) @ Bk  rn) t_wcode_adjust n) 
        wadjust_stop m (bl_bin (<args>) - Suc 0) holds_for steps0
        (Suc 0, Bk # Oc # Oc  m, Bk # Oc # Bk  ln @ Bk # Bk # Oc  bl_bin (<args>) @ Bk  rn) t_wcode_adjust n"
        apply(rule_tac x = n in exI)
        using a
        apply(case_tac "bl_bin (<args>)", simp, simp del: replicate_Suc add: exp_ind wadjust_inv.simps)
        by (simp add: replicate_append_same)
    qed
  qed
  thus "?thesis"
    apply(simp add: Hoare_halt_def, auto)
    apply(rename_tac n)
    apply(case_tac "(steps0 (Suc 0, [], <(m::nat) # args>) 
      ((t_wcode_prepare |+| t_wcode_main) |+| t_wcode_adjust) n)")
    apply(rule_tac x = n in exI, auto simp: wadjust_stop.simps)
    using a
    apply(case_tac "bl_bin (<args>)", simp_all)
    done
qed

text ‹
  The initialization TM t_wcode›.
›
definition t_wcode :: "instr list"
  where
    "t_wcode = (t_wcode_prepare |+| t_wcode_main) |+| t_wcode_adjust        "

text ‹
  The correctness of t_wcode›.
›

lemma wcode_lemma_1:
  "args  []  
   stp ln rn. steps0 (Suc 0, [], <m # args>)  (t_wcode) stp = 
              (0,  [Bk],  Oc(Suc m) @ Bk # Oc(Suc (bl_bin (<args>))) @ Bk(rn))"
  apply(simp add: wcode_lemma_pre' t_wcode_def del: replicate_Suc)
  done

lemma wcode_lemma: 
  "args  []  
   stp ln rn. steps0 (Suc 0, [], <m # args>)  (t_wcode) stp = 
              (0,  [Bk],  <[m ,bl_bin (<args>)]> @ Bk(rn))"
  using wcode_lemma_1[of args m]
  apply(simp add: t_wcode_def tape_of_list_def tape_of_nat_def)
  done

section ‹The universal TM›

text ‹
  This section gives the explicit construction of {\em Universal Turing Machine}, defined as UTM› and proves its 
  correctness. It is pretty easy by composing the partial results we have got so far.
›


definition UTM :: "instr list"
  where
    "UTM = (let (aprog, rs_pos, a_md) = rec_ci rec_F in 
          let abc_F = aprog [+] dummy_abc (Suc (Suc 0)) in 
          (t_wcode |+| (tm_of abc_F @ shift (mopup (Suc (Suc 0))) (length (tm_of abc_F) div 2))))"

definition F_aprog :: "abc_prog"
  where
    "F_aprog  (let (aprog, rs_pos, a_md) = rec_ci rec_F in 
                       aprog [+] dummy_abc (Suc (Suc 0)))"

definition F_tprog :: "instr list"
  where
    "F_tprog = tm_of (F_aprog)"

definition t_utm :: "instr list"
  where
    "t_utm 
     F_tprog @ shift (mopup (Suc (Suc 0))) (length F_tprog div 2)"

definition UTM_pre :: "instr list"
  where
    "UTM_pre = t_wcode |+| t_utm"

lemma tinres_step1: 
  assumes "tinres l l'" "step (ss, l, r) (t, 0) = (sa, la, ra)" 
    "step (ss, l', r) (t, 0) = (sb, lb, rb)"
  shows "tinres la lb  ra = rb  sa = sb"
proof(cases "r")
  case Nil
  then show ?thesis using assms
    by (cases "(fetch t ss Bk)";cases "fst (fetch t ss Bk)";auto simp:step.simps split:if_splits)
next
  case (Cons a list)
  then show ?thesis using assms
    by (cases "(fetch t ss a)";cases "fst (fetch t ss a)";auto simp:step.simps split:if_splits)
qed

lemma tinres_steps1: 
  "tinres l l'; steps (ss, l, r) (t, 0) stp = (sa, la, ra); 
                 steps (ss, l', r) (t, 0) stp = (sb, lb, rb)
     tinres la lb  ra = rb  sa = sb"
proof (induct stp arbitrary: sa la ra sb lb rb)
  case (Suc stp)
  then show ?case apply simp 
    apply(case_tac "(steps (ss, l, r) (t, 0) stp)")
    apply(case_tac "(steps (ss, l', r) (t, 0) stp)")
  proof -
    fix stp sa la ra sb lb rb a b c aa ba ca
    assume ind: "sa la ra sb lb rb. steps (ss, l, r) (t, 0) stp = (sa, (la::cell list), ra); 
          steps (ss, l', r) (t, 0) stp = (sb, lb, rb)  tinres la lb  ra = rb  sa = sb"
      and h: " tinres l l'" "step (steps (ss, l, r) (t, 0) stp) (t, 0) = (sa, la, ra)"
      "step (steps (ss, l', r) (t, 0) stp) (t, 0) = (sb, lb, rb)" "steps (ss, l, r) (t, 0) stp = (a, b, c)" 
      "steps (ss, l', r) (t, 0) stp = (aa, ba, ca)"
    have "tinres b ba  c = ca  a = aa"
      using ind h by metis
    thus "tinres la lb  ra = rb  sa = sb"
      using tinres_step1 h by metis
  qed
qed (simp add: steps.simps)

lemma tinres_some_exp[simp]: 
  "tinres (Bk  m @ [Bk, Bk]) la  m. la = Bk  m" unfolding tinres_def
proof -
  let ?c1 = "λ n. Bk  m @ [Bk, Bk] = la @ Bk  n"
  let ?c2 = "λ n. la = (Bk  m @ [Bk, Bk]) @ Bk  n"
  assume "n. ?c1 n  ?c2 n"
  then obtain n where "?c1 n  ?c2 n" by auto
  then consider "?c1 n" | "?c2 n" by blast
  thus ?thesis proof(cases)
    case 1
    hence "Bk  Suc (Suc m) = la @ Bk  n"
      by (metis exp_ind append_Cons append_eq_append_conv2 self_append_conv2)
    hence "la = Bk  (Suc (Suc m) - n)"
      by (metis replicate_add append_eq_append_conv diff_add_inverse2 length_append length_replicate)
    then show ?thesis by auto
  next
    case 2
    hence "la = Bk  (m + Suc (Suc n))"
      by (metis append_Cons append_eq_append_conv2 replicate_Suc replicate_add self_append_conv2)
    then show ?thesis by blast
  qed
qed

lemma t_utm_halt_eq: 
  assumes tm_wf: "tm_wf (tp, 0)"
    and exec: "steps0 (Suc 0, Bk(l), <lm::nat list>) tp stp = (0, Bk(m), Oc(rs)@Bk(n))"
    and resutl: "0 < rs"
  shows "stp m n. steps0 (Suc 0, [Bk], <[code tp, bl2wc (<lm>)]> @ Bk(i)) t_utm stp = 
                                                (0, Bk(m), Oc(rs) @ Bk(n))"
proof -
  obtain ap arity fp where a: "rec_ci rec_F = (ap, arity, fp)"
    by (metis prod_cases3) 
  moreover have b: "rec_exec rec_F [code tp, (bl2wc (<lm>))] = (rs - Suc 0)"
    using assms
    apply(rule_tac F_correct, simp_all)
    done 
  have " stp m l. steps0 (Suc 0, Bk # Bk # [], <[code tp, bl2wc (<lm>)]> @ Bki)
    (F_tprog @ shift (mopup (length [code tp, bl2wc (<lm>)])) (length F_tprog div 2)) stp
    = (0, Bkm @ Bk # Bk # [], OcSuc (rec_exec rec_F [code tp, (bl2wc (<lm>))]) @ Bkl)"  
  proof(rule_tac recursive_compile_to_tm_correct1)
    show "rec_ci rec_F = (ap, arity, fp)" using a by simp
  next
    show "terminate rec_F [code tp, bl2wc (<lm>)]"
      using assms
      by(rule_tac terminate_F, simp_all)
  next
    show "F_tprog = tm_of (ap [+] dummy_abc (length [code tp, bl2wc (<lm>)]))"
      using a
      apply(simp add: F_tprog_def F_aprog_def numeral_2_eq_2)
      done
  qed
  then obtain stp m l where 
    "steps0 (Suc 0, Bk # Bk # [], <[code tp, bl2wc (<lm>)]> @ Bki)
    (F_tprog @ shift (mopup (length [code tp, (bl2wc (<lm>))])) (length F_tprog div 2)) stp
    = (0, Bkm @ Bk # Bk # [], OcSuc (rec_exec rec_F [code tp, (bl2wc (<lm>))]) @ Bkl)" by blast
  hence " m. steps0 (Suc 0, [Bk], <[code tp, bl2wc (<lm>)]> @ Bki)
    (F_tprog @ shift (mopup 2) (length F_tprog div 2)) stp
    = (0, Bkm, OcSuc (rs - 1) @ Bkl)"
  proof -
    assume g: "steps0 (Suc 0, [Bk, Bk], <[code tp, bl2wc (<lm>)]> @ Bk  i)
      (F_tprog @ shift (mopup (length [code tp, bl2wc (<lm>)])) (length F_tprog div 2)) stp =
      (0, Bk  m @ [Bk, Bk], Oc  Suc ((rec_exec rec_F [code tp, bl2wc (<lm>)])) @ Bk  l)"
    moreover have "tinres [Bk, Bk] [Bk]"
      apply(auto simp: tinres_def)
      done
    moreover obtain sa la ra where "steps0 (Suc 0, [Bk], <[code tp, bl2wc (<lm>)]> @ Bki)
    (F_tprog @ shift (mopup 2) (length F_tprog div 2)) stp = (sa, la, ra)"
      apply(case_tac "steps0 (Suc 0, [Bk], <[code tp, bl2wc (<lm>)]> @ Bki)
    (F_tprog @ shift (mopup 2) (length F_tprog div 2)) stp", auto)
      done
    ultimately show "?thesis"
      using b
      apply(drule_tac la = "Bkm @ [Bk, Bk]" in tinres_steps1, auto simp: numeral_2_eq_2)
      done
  qed
  thus "?thesis"
    apply(auto)
    apply(rule_tac x = stp in exI, simp add: t_utm_def)
    using assms
    apply(case_tac rs, simp_all add: numeral_2_eq_2)
    done
qed

lemma tm_wf_t_wcode[intro]: "tm_wf (t_wcode, 0)"
  apply(simp add: t_wcode_def)
  apply(rule_tac tm_comp_wf)
   apply(rule_tac tm_comp_wf, auto)
  done

lemma UTM_halt_lemma_pre: 
  assumes wf_tm: "tm_wf (tp, 0)"
    and result: "0 < rs"
    and args: "args  []"
    and exec: "steps0 (Suc 0, Bk(i), <args::nat list>) tp stp = (0, Bk(m), Oc(rs)@Bk(k))"
  shows "stp m n. steps0 (Suc 0, [], <code tp # args>) UTM_pre stp = 
                                                (0, Bk(m), Oc(rs) @ Bk(n))"
proof -
  let ?Q2 = "λ (l, r). ( ln rn. l = Bk(ln)  r = Oc(rs) @ Bk(rn))"
  let ?P1 = "λ (l, r). l = []  r = <code tp # args>"
  let ?Q1 = "λ (l, r). (l = [Bk] 
    ( rn. r = Oc(Suc (code tp)) @ Bk # Oc(Suc (bl_bin (<args>))) @ Bk(rn)))"
  let ?P2 = ?Q1
  let ?P3 = "λ (l, r). False"
  have "{?P1} (t_wcode |+| t_utm) {?Q2}"
  proof(rule_tac Hoare_plus_halt)
    show "tm_wf (t_wcode, 0)" by auto
  next
    show "{?P1} t_wcode {?Q1}"
      apply(rule_tac Hoare_haltI, auto)
      using wcode_lemma_1[of args "code tp"] args
      apply(auto)
      by (metis (mono_tags, lifting) holds_for.simps is_finalI old.prod.case)
  next
    show "{?P2} t_utm {?Q2}"
    proof(rule_tac Hoare_haltI, auto)
      fix rn
      show "n. is_final (steps0 (Suc 0, [Bk], Oc # Oc  code tp @ Bk # Oc # Oc  bl_bin (<args>) @ Bk  rn) t_utm n) 
        (λ(l, r). (ln. l = Bk  ln) 
        (rn. r = Oc  rs @ Bk  rn)) holds_for steps0 (Suc 0, [Bk],
        Oc # Oc  code tp @ Bk # Oc # Oc  bl_bin (<args>) @ Bk  rn) t_utm n"
        using t_utm_halt_eq[of tp i "args" stp m rs k rn] assms
        apply(auto simp: bin_wc_eq tape_of_list_def tape_of_nat_def)
        apply(rename_tac stpa) apply(rule_tac x = stpa in exI, simp)
        done
    qed
  qed
  thus "?thesis"
    apply(auto simp: Hoare_halt_def UTM_pre_def)
    apply(case_tac "steps0 (Suc 0, [], <code tp # args>) (t_wcode |+| t_utm) n",simp)
    by auto
qed

text ‹
  The correctness of UTM›, the halt case.
›
lemma UTM_halt_lemma': 
  assumes tm_wf: "tm_wf (tp, 0)"
    and result: "0 < rs"
    and args: "args  []"
    and exec: "steps0 (Suc 0, Bk(i), <args::nat list>) tp stp = (0, Bk(m), Oc(rs)@Bk(k))"
  shows "stp m n. steps0 (Suc 0, [], <code tp # args>) UTM stp = 
                                                (0, Bk(m), Oc(rs) @ Bk(n))"
  using UTM_halt_lemma_pre[of tp rs args i stp m k] assms
  apply(simp add: UTM_pre_def t_utm_def UTM_def F_aprog_def F_tprog_def)
  apply(case_tac "rec_ci rec_F", simp)
  done

definition TSTD:: "config  bool"
  where
    "TSTD c = (let (st, l, r) = c in 
             st = 0  ( m. l = Bk(m))  ( rs n. r = Oc(Suc rs) @ Bk(n)))"

lemma nstd_case1: "0 < a  NSTD (trpl_code (a, b, c))"
  by(simp add: NSTD.simps trpl_code.simps)

lemma nonzero_bl2wc[simp]: "m. b  Bk(m)  0 < bl2wc b"
proof -
  have "m. b  Bk  m  bl2wc b = 0  False" proof(induct b)
    case (Cons a b)
    then show ?case
      apply(simp add: bl2wc.simps, case_tac a, simp_all 
          add: bl2nat.simps bl2nat_double)
      apply(case_tac " m. b = Bk(m)", erule exE)
       apply(metis append_Nil2 replicate_Suc_iff_anywhere) 
      by simp
  qed auto
  thus "m. b  Bk(m)  0 < bl2wc b" by auto
qed

lemma nstd_case2: "m. b  Bk(m)  NSTD (trpl_code (a, b, c))"
  apply(simp add: NSTD.simps trpl_code.simps)
  done

lemma even_not_odd[elim]: "Suc (2 * x) = 2 * y  RR"
proof(induct x arbitrary: y)
  case (Suc x) thus ?case by(cases y;auto)
qed auto

declare replicate_Suc[simp del]

lemma bl2nat_zero_eq[simp]: "(bl2nat c 0 = 0) = (n. c = Bk(n))"
proof(induct c)
  case (Cons a c)
  then show ?case by (cases a;auto simp: bl2nat.simps bl2nat_double Cons_replicate_eq)
qed (auto simp: bl2nat.simps)

lemma bl2wc_exp_ex: 
  "Suc (bl2wc c) = 2 ^  m   rs n. c = Oc(rs) @ Bk(n)"
proof(induct c arbitrary: m)
  case (Cons a c m)
  { fix n
    have "Bk # Bk  n = Oc  0 @ Bk  Suc n" by (auto simp:replicate_Suc)
    hence "rs na. Bk # Bk  n = Oc  rs @ Bk  na" by blast
  }
  with Cons show ?case apply(cases a, auto)
     apply(case_tac m, simp_all add: bl2wc.simps, auto)
    apply(simp add: bl2wc.simps bl2nat.simps bl2nat_double Cons)
    apply(case_tac m, simp, simp add: bin_wc_eq bl2wc.simps twice_power )
    by (metis Cons.hyps Suc_pred bl2wc.simps neq0_conv power_not_zero
        replicate_Suc_iff_anywhere zero_neq_numeral)
qed (simp add: bl2wc.simps bl2nat.simps)

lemma lg_bin: 
  assumes "rs n. c  Oc(Suc rs) @ Bk(n)" 
    "bl2wc c = 2 ^ lg (Suc (bl2wc c)) 2 - Suc 0"
  shows "bl2wc c = 0"
proof -
  from assms obtain rs nat n where *:"2 ^ rs - Suc 0 = nat"
    "c = Oc  rs @ Bk  n" 
    using bl2wc_exp_ex[of c "lg (Suc (bl2wc c)) 2"]
    by(case_tac "(2::nat) ^ lg (Suc (bl2wc c)) 2", 
        simp, simp, erule_tac exE, erule_tac exE, simp)
  have r:"bl2wc (Oc  rs) = nat" 
    by (metis "*"(1) bl2nat_exp_zero bl2wc.elims)
  hence "Suc (bl2wc c) = 2^rs" using *
    by(case_tac "(2::nat)^rs", auto)
  thus ?thesis using * assms(1)
    apply(drule_tac bl2wc_exp_ex, simp, erule_tac exE, erule_tac exE)
    by(case_tac rs, simp, simp)
qed

lemma nstd_case3: 
  "rs n. c  Oc(Suc rs) @ Bk(n)   NSTD (trpl_code (a, b, c))"
  apply(simp add: NSTD.simps trpl_code.simps)
  apply(auto)
  apply(drule_tac lg_bin, simp_all)
  done

lemma NSTD_1: "¬ TSTD (a, b, c)
     rec_exec rec_NSTD [trpl_code (a, b, c)] = Suc 0"
  using NSTD_lemma1[of "trpl_code (a, b, c)"]
    NSTD_lemma2[of "trpl_code (a, b, c)"]
  apply(simp add: TSTD_def)
  apply(erule_tac disjE, erule_tac nstd_case1)
  apply(erule_tac disjE, erule_tac nstd_case2)
  apply(erule_tac nstd_case3)
  done

lemma nonstop_t_uhalt_eq:
  "tm_wf (tp, 0);
  steps0 (Suc 0, Bk(l), <lm>) tp stp = (a, b, c);
  ¬ TSTD (a, b, c)
   rec_exec rec_nonstop [code tp, bl2wc (<lm>), stp] = Suc 0"
  apply(simp add: rec_nonstop_def rec_exec.simps)
  apply(subgoal_tac 
      "rec_exec rec_conf [code tp, bl2wc (<lm>), stp] =
  trpl_code (a, b, c)", simp)
   apply(erule_tac NSTD_1)
  using rec_t_eq_steps[of tp l lm stp]
  apply(simp)
  done

lemma nonstop_true:
  "tm_wf (tp, 0);
   stp. (¬ TSTD (steps0 (Suc 0, Bk(l), <lm>) tp stp))
   y. rec_exec rec_nonstop ([code tp, bl2wc (<lm>), y]) = (Suc 0)"
proof fix y
  assume a:"tm_wf0 tp" "stp. ¬ TSTD (steps0 (Suc 0, Bk  l, <lm>) tp stp)"
  hence "¬ TSTD (steps0 (Suc 0, Bk  l, <lm>) tp y)" by auto
  thus "rec_exec rec_nonstop [code tp, bl2wc (<lm>), y] = Suc 0"
    by (cases "steps0 (Suc 0, Bk(l), <lm>) tp y")
      (auto intro: nonstop_t_uhalt_eq[OF a(1)])
qed

lemma cn_arity:  "rec_ci (Cn n f gs) = (a, b, c)  b = n"
  by(case_tac "rec_ci f", simp add: rec_ci.simps)

lemma mn_arity: "rec_ci (Mn n f) = (a, b, c)  b = n"
  by(case_tac "rec_ci f", simp add: rec_ci.simps)

lemma F_aprog_uhalt: 
  assumes wf_tm: "tm_wf (tp,0)"
    and unhalt:  " stp. (¬ TSTD (steps0 (Suc 0, Bk(l), <lm>) tp stp))"
    and compile: "rec_ci rec_F = (F_ap, rs_pos, a_md)"
  shows "{λ nl. nl = [code tp, bl2wc (<lm>)] @ 0(a_md - rs_pos ) @ suflm} (F_ap) "
  using compile
proof(simp only: rec_F_def)
  assume h: "rec_ci (Cn (Suc (Suc 0)) rec_valu [Cn (Suc (Suc 0)) rec_right [Cn (Suc (Suc 0)) 
    rec_conf [recf.id (Suc (Suc 0)) 0, recf.id (Suc (Suc 0)) (Suc 0), rec_halt]]]) =
    (F_ap, rs_pos, a_md)"
  moreover hence "rs_pos = Suc (Suc 0)"
    using cn_arity 
    by simp
  moreover obtain ap1 ar1 ft1 where a: "rec_ci 
    (Cn (Suc (Suc 0)) rec_right 
    [Cn (Suc (Suc 0)) rec_conf [recf.id (Suc (Suc 0)) 0, recf.id (Suc (Suc 0)) (Suc 0), rec_halt]]) = (ap1, ar1, ft1)"
    by(case_tac "rec_ci (Cn (Suc (Suc 0)) rec_right [Cn (Suc (Suc 0)) 
      rec_conf [recf.id (Suc (Suc 0)) 0, recf.id (Suc (Suc 0)) (Suc 0), rec_halt]])", auto)
  moreover hence b: "ar1 = Suc (Suc 0)"
    using cn_arity by simp
  ultimately show "?thesis"
  proof(rule_tac i = 0 in cn_unhalt_case, auto)
    fix anything
    obtain ap2 ar2 ft2 where c: 
      "rec_ci (Cn (Suc (Suc 0)) rec_conf [recf.id (Suc (Suc 0)) 0, recf.id (Suc (Suc 0)) (Suc 0), rec_halt])
      = (ap2, ar2, ft2)" 
      by(case_tac "rec_ci (Cn (Suc (Suc 0)) rec_conf
        [recf.id (Suc (Suc 0)) 0, recf.id (Suc (Suc 0)) (Suc 0), rec_halt])", auto)
    moreover hence d:"ar2 = Suc (Suc 0)"
      using cn_arity by simp
    ultimately have "{λnl. nl = [code tp, bl2wc (<lm>)] @ 0  (ft1 - Suc (Suc 0)) @ anything} ap1 "
      using a b c d
    proof(rule_tac i = 0 in cn_unhalt_case, auto)
      fix anything
      obtain ap3 ar3 ft3 where e: "rec_ci rec_halt = (ap3, ar3, ft3)"
        by(case_tac "rec_ci rec_halt", auto)
      hence f: "ar3 = Suc (Suc 0)"
        using mn_arity
        by(simp add: rec_halt_def)
      have "{λnl. nl = [code tp, bl2wc (<lm>)] @ 0  (ft2 - Suc (Suc 0)) @ anything} ap2 "
        using c d e f
      proof(rule_tac i = 2 in cn_unhalt_case, auto simp: rec_halt_def)
        fix anything
        have "{λnl. nl = [code tp, bl2wc (<lm>)] @ 0  (ft3 - Suc (Suc 0)) @ anything} ap3 "
          using e f
        proof(rule_tac mn_unhalt_case, auto simp: rec_halt_def)
          fix i
          show "terminate rec_nonstop [code tp, bl2wc (<lm>), i]"
            by(rule_tac primerec_terminate, auto)
        next
          fix i
          show "0 < rec_exec rec_nonstop [code tp, bl2wc (<lm>), i]"
            using assms
            by(drule_tac nonstop_true, auto)
        qed
        thus "{λnl. nl = code tp # bl2wc (<lm>) # 0  (ft3 - Suc (Suc 0)) @ anything} ap3 " by simp
      next
        fix apj arj ftj j  anything
        assume "j<2" "rec_ci ([recf.id (Suc (Suc 0)) 0, recf.id (Suc (Suc 0)) (Suc 0), Mn (Suc (Suc 0)) rec_nonstop] ! j) = (apj, arj, ftj)"
        hence "{λnl. nl = [code tp, bl2wc (<lm>)] @ 0  (ftj - arj) @ anything} apj
          {λnl. nl = [code tp, bl2wc (<lm>)] @
            rec_exec ([recf.id (Suc (Suc 0)) 0, recf.id (Suc (Suc 0)) (Suc 0), Mn (Suc (Suc 0)) rec_nonstop] ! j) [code tp, bl2wc (<lm>)] # 
               0  (ftj - Suc arj) @ anything}"
          apply(rule_tac recursive_compile_correct)
           apply(case_tac j, auto)
           apply(rule_tac [!] primerec_terminate)
          by(auto)
        thus "{λnl. nl = code tp # bl2wc (<lm>) # 0  (ftj - arj) @ anything} apj
          {λnl. nl = code tp # bl2wc (<lm>) # rec_exec ([recf.id (Suc (Suc 0)) 0, recf.id (Suc (Suc 0))
          (Suc 0), Mn (Suc (Suc 0)) rec_nonstop] ! j) [code tp, bl2wc (<lm>)] # 0  (ftj - Suc arj) @ anything}"
          by simp
      next
        fix j
        assume "(j::nat) < 2"
        thus "terminate ([recf.id (Suc (Suc 0)) 0, recf.id (Suc (Suc 0)) (Suc 0), Mn (Suc (Suc 0)) rec_nonstop] ! j)
          [code tp, bl2wc (<lm>)]"
          by(case_tac j, auto intro!: primerec_terminate)
      qed
      thus "{λnl. nl = code tp # bl2wc (<lm>) # 0  (ft2 - Suc (Suc 0)) @ anything} ap2 "
        by simp
    qed
    thus "{λnl. nl = code tp # bl2wc (<lm>) # 0  (ft1 - Suc (Suc 0)) @ anything} ap1 " by simp
  qed
qed

lemma uabc_uhalt': 
  "tm_wf (tp, 0);
   stp. (¬ TSTD (steps0 (Suc 0, Bk(l), <lm>) tp stp));
  rec_ci rec_F = (ap, pos, md)
   {λ nl. nl = [code tp, bl2wc (<lm>)]} ap "
proof(frule_tac F_ap = ap and rs_pos = pos and a_md = md
    and suflm = "[]" in F_aprog_uhalt, auto simp: abc_Hoare_unhalt_def, 
    case_tac "abc_steps_l (0, [code tp, bl2wc (<lm>)]) ap n", simp)
  fix n a b
  assume h: 
    "n. abc_notfinal (abc_steps_l (0, code tp # bl2wc (<lm>) # 0  (md - pos)) ap n) ap"
    "abc_steps_l (0, [code tp, bl2wc (<lm>)]) ap n = (a, b)" 
    "tm_wf (tp, 0)" 
    "rec_ci rec_F = (ap, pos, md)"
  moreover have a: "ap  []"
    using h rec_ci_not_null[of "rec_F" pos md] by auto
  ultimately show "a < length ap"
  proof(erule_tac x = n in allE)
    assume g: "abc_notfinal (abc_steps_l (0, code tp # bl2wc (<lm>) # 0  (md - pos)) ap n) ap"
    obtain ss nl where b : "abc_steps_l (0, code tp # bl2wc (<lm>) # 0  (md - pos)) ap n = (ss, nl)"
      by (metis prod.exhaust)
    then have c: "ss < length ap"
      using g by simp
    thus "?thesis"
      using a b c
      using abc_list_crsp_steps[of "[code tp, bl2wc (<lm>)]"
          "md - pos" ap n ss nl] h
      by(simp)
  qed
qed

lemma uabc_uhalt: 
  "tm_wf (tp, 0); 
   stp. (¬ TSTD (steps0 (Suc 0, Bk(l), <lm>) tp stp))
   {λ nl. nl = [code tp, bl2wc (<lm>)]} F_aprog  "
proof -
  obtain a b c where abc:"rec_ci rec_F = (a,b,c)" by (cases "rec_ci rec_F") force
  assume a:"tm_wf (tp, 0)" " stp. (¬ TSTD (steps0 (Suc 0, Bk(l), <lm>) tp stp))"
  from uabc_uhalt'[OF a abc] abc_Hoare_plus_unhalt1
  show "{λ nl. nl = [code tp, bl2wc (<lm>)]} F_aprog "
    by(simp add: F_aprog_def abc)
qed

lemma tutm_uhalt': 
  assumes tm_wf:  "tm_wf (tp,0)"
    and unhalt: " stp. (¬ TSTD (steps0 (1, Bk(l), <lm>) tp stp))"
  shows " stp. ¬ is_final (steps0 (1, [Bk, Bk], <[code tp, bl2wc (<lm>)]>) t_utm stp)"
  unfolding t_utm_def
proof(rule_tac compile_correct_unhalt, auto)
  show "F_tprog = tm_of F_aprog"
    by(simp add:  F_tprog_def)
next
  show "crsp (layout_of F_aprog) (0, [code tp, bl2wc (<lm>)]) (Suc 0, [Bk, Bk], <[code tp, bl2wc (<lm>)]>)  []"
    by(auto simp: crsp.simps start_of.simps)
next
  fix stp a b
  show "abc_steps_l (0, [code tp, bl2wc (<lm>)]) F_aprog stp = (a, b)  a < length F_aprog"
    using assms
    apply(drule_tac uabc_uhalt, auto simp: abc_Hoare_unhalt_def)
    by(erule_tac x = stp in allE, erule_tac x = stp in allE, simp) 
qed

lemma tinres_commute: "tinres r r'  tinres r' r"
  apply(auto simp: tinres_def)
  done

lemma inres_tape:
  "steps0 (st, l, r) tp stp = (a, b, c); steps0 (st, l', r') tp stp = (a', b', c'); 
  tinres l l'; tinres r r'
   a = a'  tinres b b'  tinres c c'"
proof(case_tac "steps0 (st, l', r) tp stp")
  fix aa ba ca
  assume h: "steps0 (st, l, r) tp stp = (a, b, c)" 
    "steps0 (st, l', r') tp stp = (a', b', c')"
    "tinres l l'" "tinres r r'"
    "steps0 (st, l', r) tp stp = (aa, ba, ca)"
  have "tinres b ba  c = ca  a = aa"
    using h
    apply(rule_tac tinres_steps1, auto)
    done
  moreover have "b' = ba  tinres c' ca  a' =  aa"
    using h
    apply(rule_tac tinres_steps2, auto intro: tinres_commute)
    done
  ultimately show "?thesis"
    apply(auto intro: tinres_commute)
    done
qed

lemma tape_normalize:
  assumes " stp. ¬ is_final(steps0 (Suc 0, [Bk,Bk], <[code tp, bl2wc (<lm>)]>) t_utm stp)"
  shows   " stp. ¬ is_final (steps0 (Suc 0, Bk(m), <[code tp, bl2wc (<lm>)]> @ Bk(n)) t_utm stp)"
    (is " stp. ?P stp")
proof
  fix stp
  from assms[rule_format,of stp] show "?P stp"
    apply(case_tac "steps0 (Suc 0, Bk(m), <[code tp, bl2wc (<lm>)]> @ Bk(n)) t_utm stp", simp)
    apply(case_tac "steps0 (Suc 0, [Bk, Bk], <[code tp, bl2wc (<lm>)]>) t_utm stp", simp)
    apply(drule_tac inres_tape, auto)
     apply(auto simp: tinres_def)
    apply(case_tac "m > Suc (Suc 0)")
     apply(rule_tac x = "m - Suc (Suc 0)" in exI) 
     apply(case_tac m, simp_all)
     apply(metis Suc_lessD Suc_pred replicate_Suc)
    apply(rule_tac x = "2 - m" in exI, simp add: replicate_add[THEN sym])
    apply(simp only: numeral_2_eq_2, simp add: replicate_Suc)
    done
qed

lemma tutm_uhalt: 
  "tm_wf (tp,0);
     stp. (¬ TSTD (steps0 (Suc 0, Bk(l), <args>) tp stp))
    stp. ¬ is_final (steps0 (Suc 0, Bk(m), <[code tp, bl2wc (<args>)]> @ Bk(n)) t_utm stp)"
  apply(rule_tac tape_normalize)
  apply(rule_tac tutm_uhalt'[simplified], simp_all)
  done

lemma UTM_uhalt_lemma_pre:
  assumes tm_wf: "tm_wf (tp, 0)"
    and exec: " stp. (¬ TSTD (steps0 (Suc 0, Bk(l), <args>) tp stp))"
    and args: "args  []"
  shows " stp. ¬ is_final (steps0 (Suc 0, [], <code tp # args>)  UTM_pre stp)"
proof -
  let ?P1 = "λ (l, r). l = []  r = <code tp # args>"
  let ?Q1 = "λ (l, r). (l = [Bk] 
             ( rn. r = Oc(Suc (code tp)) @ Bk # Oc(Suc (bl_bin (<args>))) @ Bk(rn)))"
  let ?P2 = ?Q1
  have "{?P1} (t_wcode |+| t_utm) "
  proof(rule_tac Hoare_plus_unhalt)
    show "tm_wf (t_wcode, 0)" by auto
  next
    show "{?P1} t_wcode {?Q1}"
      apply(rule_tac Hoare_haltI, auto)
      using wcode_lemma_1[of args "code tp"] args
      apply(auto)
      by (metis (mono_tags, lifting) holds_for.simps is_finalI old.prod.case)
  next
    show "{?P2} t_utm "
    proof(rule_tac Hoare_unhaltI, auto)
      fix n rn
      assume h: "is_final (steps0 (Suc 0, [Bk], Oc  Suc (code tp) @ Bk # Oc  Suc (bl_bin (<args>)) @ Bk  rn) t_utm n)"
      have " stp. ¬ is_final (steps0 (Suc 0, Bk(Suc 0), <[code tp, bl2wc (<args>)]> @ Bk(rn)) t_utm stp)"
        using assms
        apply(rule_tac tutm_uhalt, simp_all)
        done
      thus "False"
        using h
        apply(erule_tac x = n in allE)
        apply(simp add: tape_of_list_def bin_wc_eq tape_of_nat_def)
        done
    qed
  qed
  thus "?thesis"
    apply(simp add: Hoare_unhalt_def UTM_pre_def)
    done
qed

text ‹
  The correctness of UTM›, the unhalt case.
›

lemma UTM_uhalt_lemma':
  assumes tm_wf: "tm_wf (tp, 0)"
    and unhalt: " stp. (¬ TSTD (steps0 (Suc 0, Bk(l), <args>) tp stp))"
    and args: "args  []"
  shows "  stp. ¬ is_final (steps0 (Suc 0, [], <code tp # args>)  UTM stp)"
  using UTM_uhalt_lemma_pre[of tp l args] assms
  apply(simp add: UTM_pre_def t_utm_def UTM_def F_aprog_def F_tprog_def)
  apply(case_tac "rec_ci rec_F", simp)
  done

lemma UTM_halt_lemma:
  assumes tm_wf: "tm_wf (p, 0)"
    and resut: "rs > 0"
    and args: "(args::nat list)  []"
    and exec: "{(λtp. tp = (Bki, <args>))} p {(λtp. tp = (Bkm, Ocrs @ Bkk))}" 
  shows "{(λtp. tp = ([], <code p # args>))} UTM {(λtp. ( m n. tp = (Bkm, Ocrs @ Bkn)))}"
proof -
  let ?steps0 = "steps0 (Suc 0, [], <code p # args>)"
  let ?stepsBk = "steps0 (Suc 0, Bki, <args>) p"
  from wcode_lemma_1[OF args,of "code p"] obtain stp ln rn where
    wcl1:"?steps0 t_wcode stp =
     (0, [Bk], Oc  Suc (code p) @ Bk # Oc  Suc (bl_bin (<args>)) @ Bk  rn)" by fast
  from exec Hoare_halt_def obtain n where
    n:"{λtp. tp = (Bk  i, <args>)} p {λtp. tp = (Bk  m, Oc  rs @ Bk  k)}"
    "is_final (?stepsBk n)"
    "(λtp. tp = (Bk  m, Oc  rs @ Bk  k)) holds_for steps0 (Suc 0, Bk  i, <args>) p n"
    by auto
  obtain a where a:"a = fst (rec_ci rec_F)" by blast
  have "{(λ (l, r). l = []  r = <code p # args>)} (t_wcode |+| t_utm)
          {(λ (l, r). ( m. l = Bkm)  ( n. r = Ocrs @ Bkn))}"
  proof(rule_tac Hoare_plus_halt)
    show "{λ(l, r). l = []  r = <code p # args>} t_wcode {λ (l, r). (l = [Bk] 
    ( rn. r = Oc(Suc (code p)) @ Bk # Oc(Suc (bl_bin (<args>))) @ Bk(rn)))}"
      using wcl1 by (auto intro!:Hoare_haltI exI[of _ stp])
  next
    have " stp. (?stepsBk stp = (0, Bkm, Ocrs @ Bkk))"
      using n by (case_tac "?stepsBk n", auto)
    then obtain stp where k: "steps0 (Suc 0, Bki, <args>) p stp = (0, Bkm, Ocrs @ Bkk)"
      ..
    thus "{λ(l, r). l = [Bk]  (rn. r = Oc  Suc (code p) @ Bk # Oc  Suc (bl_bin (<args>)) @ Bk  rn)}
      t_utm {λ(l, r). (m. l = Bk  m)  (n. r = Oc  rs @ Bk  n)}"
    proof(rule_tac Hoare_haltI, auto)
      fix rn
      from t_utm_halt_eq[OF assms(1) k assms(2),of rn] assms k
      have " ma n stp. steps0 (Suc 0, [Bk], <[code p, bl2wc (<args>)]> @ Bk  rn) t_utm stp =
       (0, Bk  ma, Oc  rs @ Bk  n)" by (auto simp add: bin_wc_eq)
      then obtain stpx m' n' where
        t:"steps0 (Suc 0, [Bk], <[code p, bl2wc (<args>)]> @ Bk  rn) t_utm stpx =
       (0, Bk  m', Oc  rs @ Bk  n')" by auto
      show "n. is_final (steps0 (Suc 0, [Bk], Oc  Suc (code p) @ Bk # Oc  Suc (bl_bin (<args>)) @ Bk  rn) t_utm n) 
             (λ(l, r). (m. l = Bk  m)  (n. r = Oc  rs @ Bk  n)) holds_for steps0 
         (Suc 0, [Bk], Oc  Suc (code p) @ Bk # Oc  Suc (bl_bin (<args>)) @ Bk  rn) t_utm n"      
        using t
        by(auto simp: bin_wc_eq tape_of_list_def tape_of_nat_def intro:exI[of _ stpx])
    qed
  next
    show "tm_wf0 t_wcode" by auto
  qed
  then obtain n where
    "is_final (?steps0 (t_wcode |+| t_utm) n)" 
    "(λ(l, r). (m. l = Bk  m) 
           (n. r = Oc  rs @ Bk  n)) holds_for ?steps0 (t_wcode |+| t_utm) n"
    by(auto simp add: Hoare_halt_def a)
  thus "?thesis"
    apply(case_tac "rec_ci rec_F")
    apply(auto simp add: UTM_def Hoare_halt_def)
    apply(case_tac "(?steps0 (t_wcode |+| t_utm) n)")
    apply(rule_tac x="n" in exI)
    apply(auto simp add:a t_utm_def F_aprog_def F_tprog_def)
    done
qed

lemma UTM_halt_lemma2:
  assumes tm_wf: "tm_wf (p, 0)"
    and args: "(args::nat list)  []"
    and exec: "{(λtp. tp = ([], <args>))} p {(λtp. tp = (Bkm, <(n::nat)> @ Bkk))}" 
  shows "{(λtp. tp = ([], <code p # args>))} UTM {(λtp. ( m k. tp = (Bkm, <n> @ Bkk)))}"
  using UTM_halt_lemma[OF assms(1) _ assms(2), where i="0"]
  using assms(3)
  by(simp add: tape_of_nat_def)

lemma UTM_unhalt_lemma: 
  assumes tm_wf: "tm_wf (p, 0)"
    and unhalt: "{(λtp. tp = (Bki, <args>))} p "
    and args: "args  []"
  shows "{(λtp. tp = ([], <code p # args>))} UTM "
proof -
  have "(¬ TSTD (steps0 (Suc 0, Bk(i), <args>) p stp))" for stp
    (* in unhalt, we substitute inner 'forall' n→stp *)
    using unhalt[unfolded Hoare_unhalt_def,rule_format,OF refl,of stp]
    by(cases "steps0 (Suc 0, Bk  i, <args>) p stp",auto simp: Hoare_unhalt_def TSTD_def)
  then have " stp. ¬ is_final (steps0 (Suc 0, [], <code p # args>)  UTM stp)"
    using assms by(intro UTM_uhalt_lemma', auto)
  thus "?thesis" by(simp add: Hoare_unhalt_def)
qed

lemma UTM_unhalt_lemma2: 
  assumes tm_wf: "tm_wf (p, 0)"
    and unhalt: "{(λtp. tp = ([], <args>))} p "
    and args: "args  []"
  shows "{(λtp. tp = ([], <code p # args>))} UTM "
  using UTM_unhalt_lemma[OF assms(1), where i="0"]
  using assms(2-3)
  by(simp add: tape_of_nat_def)

end